From 77dcef404dc78635f6ffa8f71a803d2bc7cc8921 Mon Sep 17 00:00:00 2001 From: tomo Date: Mon, 17 May 1999 09:41:38 +0000 Subject: [PATCH] XEmacs 21.2.5 --- CHANGES-beta | 12 + ChangeLog | 4 + INSTALL | 8 +- config.guess | 70 +- config.sub | 208 ++- configure | 1416 ++++++++-------- configure.in | 266 +-- configure.usage | 21 +- etc/MOTIVATION | 2 +- etc/NEWS | 80 +- lib-src/ChangeLog | 4 + lib-src/gnuclient.c | 2 +- lib-src/gnuserv.c | 8 +- lib-src/make-docfile.c | 2 +- lib-src/make-msgfile.c | 8 +- lib-src/make-msgfile.lex | 8 +- lib-src/movemail.c | 6 +- lisp/ChangeLog | 203 ++- lisp/apropos.el | 2 +- lisp/auto-show.el | 3 +- lisp/build-report.el | 5 +- lisp/byte-optimize.el | 226 +-- lisp/bytecomp-runtime.el | 24 +- lisp/bytecomp.el | 1050 ++++++------ lisp/callers-of-rpt.el | 7 +- lisp/cl-extra.el | 193 +-- lisp/cl-macs.el | 338 ++-- lisp/cl.el | 173 +- lisp/cmdloop.el | 4 +- lisp/code-files.el | 24 +- lisp/code-process.el | 36 +- lisp/config.el | 6 +- lisp/cus-edit.el | 4 +- lisp/custom.el | 3 +- lisp/derived.el | 66 +- lisp/disass.el | 22 +- lisp/dragdrop.el | 6 +- lisp/easymenu.el | 6 +- lisp/etags.el | 2 +- lisp/files.el | 175 +- lisp/fill.el | 3 +- lisp/find-paths.el | 9 +- lisp/finder.el | 77 +- lisp/font-lock.el | 9 +- lisp/font.el | 145 +- lisp/gnuserv.el | 2 +- lisp/help.el | 18 +- lisp/hyper-apropos.el | 21 +- lisp/info.el | 148 +- lisp/itimer.el | 3 +- lisp/lib-complete.el | 18 +- lisp/lisp-mnt.el | 22 +- lisp/loaddefs.el | 13 +- lisp/loadhist.el | 135 +- lisp/loadup.el | 64 +- lisp/make-docfile.el | 2 +- lisp/map-ynp.el | 72 +- lisp/menubar.el | 4 +- lisp/minibuf.el | 85 +- lisp/modeline.el | 4 +- lisp/mouse.el | 6 +- lisp/obsolete.el | 3 +- lisp/package-admin.el | 3 +- lisp/package-get.el | 1 - lisp/paragraphs.el | 2 +- lisp/paths.el | 8 +- lisp/process.el | 45 +- lisp/select.el | 2 +- lisp/setup-paths.el | 2 + lisp/shadow.el | 14 +- lisp/simple.el | 4 +- lisp/startup.el | 13 +- lisp/subr.el | 17 +- lisp/symbol-syntax.el | 6 +- lisp/syntax.el | 2 +- lisp/term/internal.el | 2 +- lisp/term/sun-mouse.el | 52 +- lisp/term/sun.el | 6 +- lisp/toolbar-items.el | 2 +- lisp/toolbar.el | 18 +- lisp/version.el | 2 +- lisp/very-early-lisp.el | 2 - lisp/view-less.el | 1 + lisp/wid-edit.el | 6 +- lisp/widget.el | 13 +- lisp/x-compose.el | 171 +- lisp/x-init.el | 64 +- lisp/x-iso8859-1.el | 18 +- lisp/x-mouse.el | 2 +- lisp/x-win-sun.el | 24 +- lisp/x-win-xfree86.el | 1 + lwlib/Makefile.in.in | 2 +- lwlib/xlwmenu.c | 51 +- man/ChangeLog | 69 + man/cl.texi | 159 +- man/internals/internals.texi | 1876 ++++++++++---------- man/lispref/building.texi | 4 +- man/lispref/compile.texi | 187 +- man/lispref/errors.texi | 4 + man/lispref/hash-tables.texi | 211 ++- man/lispref/macros.texi | 16 +- man/lispref/objects.texi | 39 +- man/widget.texi | 2 +- man/xemacs-faq.texi | 6 +- man/xemacs/custom.texi | 2 +- man/xemacs/startup.texi | 6 +- nt/ChangeLog | 4 + src/ChangeLog | 702 ++++++++ src/EmacsFrame.c | 23 +- src/EmacsShell.c | 21 +- src/Makefile.in.in | 107 +- src/abbrev.c | 2 +- src/alloc.c | 1504 ++++++++-------- src/alloca.s | 10 +- src/backtrace.h | 186 +- src/balloon_help.c | 9 - src/buffer.c | 246 ++- src/buffer.h | 191 +-- src/bufslots.h | 2 +- src/bytecode.c | 2922 +++++++++++++++++++++++--------- src/bytecode.h | 52 +- src/callint.c | 10 +- src/callproc.c | 112 +- src/casefiddle.c | 18 +- src/chartab.c | 15 +- src/cmdloop.c | 1 - src/cmds.c | 173 +- src/config.h.in | 10 +- src/conslots.h | 2 +- src/console-msw.h | 22 +- src/console-tty.c | 7 +- src/console-tty.h | 20 +- src/console-x.c | 2 +- src/console-x.h | 4 +- src/console.c | 98 +- src/console.h | 20 +- src/data.c | 1116 ++++++------ src/database.c | 124 +- src/debug.c | 6 +- src/depend | 80 +- src/device-msw.c | 2 +- src/device-x.c | 122 +- src/device.c | 79 +- src/device.h | 14 +- src/dgif_lib.c | 10 +- src/dialog-msw.c | 16 +- src/dialog-x.c | 2 - src/dired.c | 39 +- src/doc.c | 24 +- src/doprnt.c | 2 +- src/dynarr.c | 4 +- src/ecrt0.c | 2 +- src/editfns.c | 39 +- src/elhash.c | 1840 ++++++++++---------- src/elhash.h | 82 +- src/emacs.c | 159 +- src/eval.c | 1835 ++++++++++---------- src/event-Xt.c | 63 +- src/event-msw.c | 32 +- src/event-stream.c | 54 +- src/events.c | 240 +-- src/events.h | 41 +- src/extents.c | 201 ++- src/extents.h | 4 +- src/faces.c | 85 +- src/faces.h | 4 +- src/file-coding.c | 104 +- src/file-coding.h | 2 +- src/fileio.c | 58 +- src/floatfns.c | 159 +- src/fns.c | 1001 +++++------ src/frame-msw.c | 14 +- src/frame-tty.c | 12 +- src/frame-x.c | 117 +- src/frame.c | 23 +- src/frame.h | 12 +- src/free-hook.c | 120 +- src/getloadavg.c | 5 +- src/gifrlib.h | 6 +- src/glyphs-eimage.c | 90 +- src/glyphs-msw.c | 14 +- src/glyphs-x.c | 30 +- src/glyphs.c | 90 +- src/glyphs.h | 15 +- src/gui-x.c | 31 +- src/gui.c | 2 +- src/hash.c | 440 +++-- src/hash.h | 80 +- src/hftctl.c | 6 +- src/imgproc.c | 2 +- src/input-method-xlib.c | 12 +- src/insdel.c | 4 +- src/intl.c | 6 +- src/keymap.c | 180 +- src/keymap.h | 4 +- src/line-number.c | 3 +- src/linuxplay.c | 7 +- src/lisp-disunion.h | 12 +- src/lisp-union.h | 33 +- src/lisp.h | 815 +++++---- src/lread.c | 66 +- src/lrecord.h | 97 +- src/lstream.c | 8 +- src/make-src-depend | 1 + src/malloc.c | 2 +- src/marker.c | 23 +- src/md5.c | 3 - src/menubar-msw.c | 90 +- src/menubar-msw.h | 2 +- src/menubar-x.c | 24 +- src/menubar.c | 6 +- src/minibuf.c | 8 +- src/mule-canna.c | 72 +- src/mule-ccl.c | 2 +- src/mule-charset.c | 68 +- src/mule-wnnfns.c | 178 +- src/nas.c | 13 +- src/nt.c | 12 +- src/ntheap.c | 2 +- src/ntproc.c | 12 +- src/objects-msw.c | 2 +- src/objects-tty.c | 4 +- src/objects-x.c | 20 +- src/objects.c | 60 +- src/offix.c | 2 +- src/opaque.c | 102 +- src/opaque.h | 41 +- src/print.c | 188 +- src/process-nt.c | 12 +- src/process-unix.c | 55 +- src/process.c | 49 +- src/procimpl.h | 4 +- src/profile.c | 49 +- src/ralloc.c | 8 +- src/rangetab.c | 6 +- src/realpath.c | 4 +- src/redisplay-msw.c | 6 +- src/redisplay-output.c | 5 +- src/redisplay-tty.c | 2 +- src/redisplay-x.c | 44 +- src/redisplay.c | 75 +- src/redisplay.h | 64 +- src/regex.c | 37 +- src/s/freebsd.h | 2 +- src/s/linux.h | 7 + src/scrollbar-msw.c | 2 +- src/scrollbar-x.c | 4 +- src/scrollbar.c | 63 +- src/search.c | 52 +- src/signal.c | 2 +- src/sound.c | 3 +- src/specifier.c | 70 +- src/specifier.h | 22 +- src/sunplay.c | 2 +- src/symbols.c | 921 +++++----- src/symeval.h | 78 +- src/symsinit.h | 2 +- src/syntax.c | 6 +- src/syntax.h | 3 +- src/sysdep.c | 90 +- src/sysdep.h | 2 +- src/sysdll.c | 4 - src/sysfile.h | 14 + src/sysproc.h | 5 - src/syssignal.h | 34 +- src/systty.h | 31 +- src/toolbar-msw.c | 18 +- src/toolbar-x.c | 2 - src/toolbar.c | 79 +- src/toolbar.h | 6 +- src/tooltalk.c | 20 +- src/tooltalk.doc | 4 +- src/unexcw.c | 2 +- src/unexec.c | 5 +- src/widget.c | 8 +- src/window.c | 171 +- src/window.h | 2 + src/xgccache.c | 65 +- src/xmu.c | 4 +- tests/automated/byte-compiler-tests.el | 93 + tests/automated/database-tests.el | 62 + tests/automated/hash-table-tests.el | 269 +++ tests/automated/lisp-tests.el | 727 ++++++++ tests/automated/test-harness.el | 367 ++++ version.sh | 4 +- 285 files changed, 16799 insertions(+), 13084 deletions(-) create mode 100644 tests/automated/byte-compiler-tests.el create mode 100644 tests/automated/database-tests.el create mode 100644 tests/automated/hash-table-tests.el create mode 100644 tests/automated/lisp-tests.el create mode 100644 tests/automated/test-harness.el diff --git a/CHANGES-beta b/CHANGES-beta index 5e7e179..374f448 100644 --- a/CHANGES-beta +++ b/CHANGES-beta @@ -1,4 +1,16 @@ -*- indented-text -*- +to 21.2 beta5 "Aphrodite" +-- bytecode interpreter rewritten +-- byte compiler fixes +-- hash table implementation rewritten +-- basic lisp functions rewritten +-- spelling fixes +-- garbage collector tuned a little +-- various global code changes for consistency +-- automated test suite +-- major internals manual updates +-- lisp reference updates + to 21.2 beta4 "Aglaophonos" -- isearch keymap fix from Katsumi Yamaoka -- directory_files cleanup from Hrvoje Niksic diff --git a/ChangeLog b/ChangeLog index a438e80..c0da2f4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff --git a/INSTALL b/INSTALL index bccc7f1..cab2f7b 100644 --- a/INSTALL +++ b/INSTALL @@ -157,11 +157,6 @@ use when compiling XEmacs. Otherwise the value of the environment variable CFLAGS is consulted. If that is also undefined, CFLAGS defaults to "-g -O" for gcc and "-g" for all other compilers. -The `--with-gnu-make' option specifies that Makefiles should be -written to take advantage of special features of GNU Make. GNU Make -works fine on Makefiles even without this option. This flag just -allows for simultaneous in-place and --srcdir building. - The `--dynamic' option specifies that configure should try to link emacs dynamically rather than statically. @@ -500,6 +495,9 @@ for its lisp files by giving values for `make' variables as part of the command. See the section below called `MAKE VARIABLES' for more information on this. +Using GNU Make allows for simultaneous builds with and without the +--srcdir option. + 8) If your system uses lock files to interlock access to mailer inbox files, then you might need to make the movemail program setuid or setgid to enable it to write the lock files. We believe this is safe. diff --git a/config.guess b/config.guess index ed660fb..6e82336 100755 --- a/config.guess +++ b/config.guess @@ -112,6 +112,9 @@ EOF amiga:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit 0 ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit 0 ;; arc64:OpenBSD:*:*) echo mips64el-unknown-openbsd${UNAME_RELEASE} exit 0 ;; @@ -139,7 +142,7 @@ EOF SR2?01:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit 0;; - Pyramid*:OSx*:*:*|MIS*:OSx*:*:*) + Pyramid*:OSx*:*:*|MIS*:OSx*:*:*|MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 @@ -219,6 +222,9 @@ EOF powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit 0 ;; + macppc:NetBSD:*:*) + echo powerpc-apple-netbsd${UNAME_RELEASE} + exit 0 ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit 0 ;; @@ -324,7 +330,8 @@ EOF fi exit 0 ;; *:AIX:*:4) - if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | head -1 | awk '{ print $1 }'` + if /usr/sbin/lsattr -EHl ${IBM_CPU_ID} | grep POWER >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc @@ -357,12 +364,44 @@ EOF hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit 0 ;; - 9000/[3478]??:HP-UX:*:*) + 9000/[34678]??:HP-UX:*:*) case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/7?? | 9000/8?[1679] ) HP_ARCH=hppa1.1 ;; - 9000/8?? ) HP_ARCH=hppa1.0 ;; + 9000/6?? | 9000/7?? | 9000/80[24] | 9000/8?[13679] | 9000/892 ) + sed 's/^ //' << EOF >dummy.c + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + ${CC-cc} dummy.c -o dummy && HP_ARCH=`./dummy` + rm -f dummy.c dummy esac HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ${HP_ARCH}-hp-hpux${HPUX_REV} @@ -468,6 +507,9 @@ EOF hp300:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit 0 ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; i?86:BSD/386:*:* | *:BSD/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit 0 ;; @@ -662,6 +704,13 @@ EOF echo ${UNAME_MACHINE}-pc-sysv32 fi exit 0 ;; + i?86:UnixWare:*:*) + if /bin/uname -X 2>/dev/null >/dev/null ; then + (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + fi + echo ${UNAME_MACHINE}-unixware-${UNAME_RELEASE}-${UNAME_VERSION} + exit 0 ;; pc:*:*:*) # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i386. @@ -745,13 +794,22 @@ EOF news*:NEWS-OS:*:6*) echo mips-sony-newsos6 exit 0 ;; - R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:*) + R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R4000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit 0 ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit 0 ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit 0 ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit 0 ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 diff --git a/config.sub b/config.sub index a4f1b4f..f791166 100755 --- a/config.sub +++ b/config.sub @@ -1,6 +1,6 @@ #! /bin/sh # Configuration validation subroutine script, version 1.1. -# Copyright (C) 1991, 92, 93, 94, 95, 1996 Free Software Foundation, Inc. +# Copyright (C) 1991, 92-97, 1998 Free Software Foundation, Inc. # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. @@ -20,8 +20,6 @@ # Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. -# Synched up with: FSF 19.31. - # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under @@ -43,6 +41,8 @@ # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. if [ x$1 = x ] @@ -64,11 +64,21 @@ case $1 in ;; esac -# Separate what the user gave into CPU-COMPANY and OS (if any). -basic_machine=`echo $1 | sed 's/-[^-]*$//'` -if [ $basic_machine != $1 ] -then os=`echo $1 | sed 's/.*-/-/'` -else os=; fi +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + linux-gnu*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also @@ -93,33 +103,33 @@ case $os in ;; -sco5) os=sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos @@ -139,32 +149,40 @@ esac case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. - tahoe | i[3-9]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ - | arme[lb] | pyramid \ - | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ - | alpha | we32k | mab | ns16k | clipper | i370 | sh \ - | powerpc | powerpcle | 1750a | dsp16xx | mips64 | mipsel \ - | pdp11 | mips64el | mips64orion | mips64orionel \ - | sparc | sparclet | sparclite | sparc64) + tahoe | i860 | m32r | m68k | m68000 | m88k | ns32k | arc | arm \ + | arme[lb] | pyramid | mn10200 | mn10300 | tron | a29k \ + | 580 | i960 | h8300 | hppa | hppa1.0 | hppa1.1 | hppa2.0 \ + | alpha | alphaev5 | alphaev56 | we32k | ns16k | clipper \ + | i370 | sh | powerpc | powerpcle | 1750a | dsp16xx | pdp11 \ + | mips64 | mipsel | mips64el | mips64orion | mips64orionel \ + | mipstx39 | mipstx39el \ + | sparc | sparclet | sparclite | sparc64 | v850) basic_machine=$basic_machine-unknown ;; + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i[34567]86) + basic_machine=$basic_machine-pc + ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. - vax-* | tahoe-* | i[3-9]86-* | i860-* | m68k-* | m68000-* | m88k-* \ - | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ - | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \ - | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \ - | hppa1.0-* | hppa1.1-* | alpha*-* | we32k-* | cydra-* | ns16k-* \ - | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \ - | pdp11-* | sh-* | powerpc-* | powerpcle-* | sparc64-* | mips64-* | mipsel-* \ - | mips64el-* | mips64orion-* | mips64orionel-* | mab-*) - ;; - # Recognize names of some NetBSD ports. - amiga-* | hp300-* | mac68k-* | sun3-* | pmax-*) + vax-* | tahoe-* | i[34567]86-* | i860-* | m32r-* | m68k-* | m68000-* \ + | m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | arm-* | c[123]* \ + | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \ + | power-* | none-* | 580-* | cray2-* | h8300-* | i960-* \ + | xmp-* | ymp-* | hppa-* | hppa1.0-* | hppa1.1-* | hppa2.0-* \ + | alpha-* | alphaev5-* | alphaev56-* | we32k-* | cydra-* \ + | ns16k-* | pn-* | np1-* | xps100-* | clipper-* | orion-* \ + | sparclite-* | pdp11-* | sh-* | powerpc-* | powerpcle-* \ + | sparc64-* | mips64-* | mipsel-* \ + | mips64el-* | mips64orion-* | mips64orionel-* \ + | mipstx39-* | mipstx39el-* \ + | f301-*) ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. @@ -191,9 +209,9 @@ case $basic_machine in amiga | amiga-*) basic_machine=m68k-cbm ;; - amigados) + amigaos | amigados) basic_machine=m68k-cbm - os=-amigados + os=-amigaos ;; amigaunix | amix) basic_machine=m68k-cbm @@ -207,10 +225,6 @@ case $basic_machine in basic_machine=m68k-apple os=-aux ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; balance) basic_machine=ns32k-sequent os=-dynix @@ -328,25 +342,28 @@ case $basic_machine in hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; + hppa-next) + os=-nextstep3 + ;; i370-ibm* | ibm*) basic_machine=i370-ibm os=-mvs ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? - i[3-9]86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; - i[3-9]86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; - i[3-9]86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; - i[3-9]86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; iris | iris4d) @@ -377,6 +394,14 @@ case $basic_machine in miniframe) basic_machine=m68000-convergent ;; + mipsel*-linux*) + basic_machine=mipsel-unknown + os=-linux-gnu + ;; + mips*-linux*) + basic_machine=mips-unknown + os=-linux-gnu + ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; @@ -442,34 +467,25 @@ case $basic_machine in basic_machine=m68k-tti ;; pc532 | pc532-*) - case $os in - -netbsd*) - basic_machine=pc532-unknown - ;; - *) - basic_machine=ns32k-pc532 - ;; - esac + basic_machine=ns32k-pc532 + ;; + pentium | p5 | k5 | nexen) + basic_machine=i586-pc ;; - pentium | p5) - basic_machine=i586-intel + pentiumpro | p6 | k6 | 6x86) + basic_machine=i686-pc ;; - pentiumpro | p6) - basic_machine=i686-intel + pentiumii | pentium2) + basic_machine=i786-pc ;; - pentium-* | p5-*) + pentium-* | p5-* | k5-* | nexen-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - pentiumpro-* | p6-*) + pentiumpro-* | p6-* | k6-* | 6x86-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - k5) - # We don't have specific support for AMD's K5 yet, so just call it a Pentium - basic_machine=i586-amd - ;; - nexen) - # We don't have specific support for Nexgen yet, so just call it a Pentium - basic_machine=i586-nexgen + pentiumii-* | pentium2-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould @@ -553,6 +569,12 @@ case $basic_machine in basic_machine=i386-sequent os=-dynix ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; tower | tower-32) basic_machine=m68k-ncr ;; @@ -572,6 +594,9 @@ case $basic_machine in basic_machine=vax-dec os=-vms ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; vxworks960) basic_machine=i960-wrs os=-vxworks @@ -599,7 +624,11 @@ case $basic_machine in # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. mips) - basic_machine=mips-mips + if [ x$os = x-linux-gnu ]; then + basic_machine=mips-unknown + else + basic_machine=mips-mips + fi ;; romp) basic_machine=romp-ibm @@ -651,6 +680,8 @@ esac if [ x"$os" != x"" ] then case $os in + # First match some system type aliases + # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` @@ -658,29 +689,37 @@ case $os in -solaris) os=-solaris2 ;; - -unixware* | svr4*) + -svr4*) os=-sysv4 ;; + -unixware*) + os=-sysv4.2uw + ;; -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux|'` + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigados* | -msdos* | -newsos* | -unicos* | -aof* | -aos* \ - | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ - | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -cygwin32* | -pe* | -psos* | -moss* | -openbsd* ) + | -cygwin32* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv* | -beos*) # Remember, each alternative MUST END IN *, to match a version number. ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; @@ -788,6 +827,9 @@ case $basic_machine in sparc-* | *-sun) os=-sunos4.1.1 ;; + *-be) + os=-beos + ;; *-ibm) os=-aix ;; @@ -801,7 +843,7 @@ case $basic_machine in os=-sysv ;; *-cbm) - os=-amigados + os=-amigaos ;; *-dg) os=-dgux @@ -851,6 +893,9 @@ case $basic_machine in *-masscomp) os=-rtu ;; + f301-fujitsu) + os=-uxpv + ;; *) os=-none ;; @@ -869,9 +914,6 @@ case $basic_machine in -sunos*) vendor=sun ;; - -lynxos*) - vendor=lynx - ;; -aix*) vendor=ibm ;; @@ -899,14 +941,12 @@ case $basic_machine in -ptx*) vendor=sequent ;; - -vxworks*) + -vxsim* | -vxworks*) vendor=wrs ;; -aux*) vendor=apple ;; - -aux*) - vendor=apple esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; diff --git a/configure b/configure index d999fb9..65b7a02 100755 --- a/configure +++ b/configure @@ -299,13 +299,11 @@ while test $# != 0; do case "$opt" in - run_in_place | \ - with_site_lisp | \ + with_site_lisp | \ with_x | \ with_x11 | \ with_msw | \ with_gcc | \ - with_gnu_make | \ dynamic | \ with_ncurses | \ with_dnet | \ @@ -322,19 +320,20 @@ while test $# != 0; do with_tiff | \ with_session | \ with_xmu | \ + with_purify | \ with_quantify | \ with_toolbars | \ with_tty | \ with_xfs | \ with_i18n3 | \ with_mule | \ - with_file_coding | \ + with_file_coding| \ with_canna | \ with_wnn | \ with_wnn6 | \ with_workshop | \ with_sparcworks | \ - with_tooltalk | \ + with_tooltalk | \ with_ldap | \ with_pop | \ with_kerberos | \ @@ -345,26 +344,25 @@ while test $# != 0; do verbose | \ extra_verbose | \ const_is_losing | \ - usage_tracking | \ - use_union_type | \ + usage_tracking | \ + use_union_type | \ debug | \ use_assertions | \ + gung_ho | \ use_minimal_tagbits | \ use_indexed_lrecord_implementation | \ - gung_ho | \ - use_assertions | \ memory_usage_stats | \ with_clash_detection | \ with_shlib | \ no_doc_file ) case "$val" in y | ye | yes ) val=yes ;; - n | no ) val=no ;; + n | no ) val=no ;; * ) (echo "$progname: Usage error:" echo " " "The \`--$optname' option requires a boolean value: \`yes' or \`no'." echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; esac - eval "$opt=\"$val\"" ;; + eval "$opt=\"$val\"" ;; srcdir | \ @@ -376,7 +374,7 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; ldflags | \ puresize | \ cache_file | \ - native_sound_lib | \ + native_sound_lib| \ site_lisp | \ x_includes | \ x_libraries | \ @@ -425,7 +423,7 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; * ) (echo "$progname: Usage error:" echo " " "The \`--$optname' option value must be either \`no' or a comma-separated list - of one or more of \`berkdb', \`dbm', or \`gnudbm'." + of one or more of \`berkdb' and either \`dbm' or \`gnudbm'." echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; esac done @@ -467,18 +465,6 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; eval "$opt=\"$val\"" ;; - "with_xfs" ) - case "$val" in - y | ye | yes ) val=yes ;; - n | no | non | none ) val=no ;; - * ) (echo "$progname: Usage error:" -echo " " "The \`--$optname' option must have one of these values: - \`yes', or \`no'." -echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; - esac - eval "$opt=\"$val\"" - ;; - "mail_locking" ) case "$val" in lockf ) val=lockf ;; @@ -542,7 +528,7 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 prefix | exec_prefix | bindir | datadir | statedir | libdir | \ mandir | infodir | infopath | lispdir | etcdir | lockdir | pkgdir | \ - archlibdir | docdir | package_path ) + archlibdir | docdir | package_path ) if test "$valomitted" = "yes"; then if test "$#" = 0; then (echo "$progname: Usage error:" @@ -642,7 +628,9 @@ EOF "usage" | "help" ) ${PAGER-more} ${srcdir}/configure.usage; exit 0 ;; - "with_menubars" | "with_scrollbars" | "with_dialogs" ) + "with_menubars" | \ + "with_scrollbars" | \ + "with_dialogs" ) case "$val" in l | lu | luc | luci | lucid ) val=lucid ;; m | mo | mot | moti | motif ) val=motif ;; @@ -657,6 +645,11 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; eval "$opt=\"$val\"" ;; + "run_in_place" | \ + "with_gnu_make" ) + echo "configure: warning: Obsolete option \`--$optname' ignored." 1>&2 + ;; + * ) (echo "$progname: Usage error:" echo " " "Unrecognized option: $arg" echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; @@ -683,13 +676,11 @@ eval set x "$quoted_arguments"; shift test "$extra_verbose" = "yes" && verbose=yes -case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac -case "$site_libraries" in *:* ) site_libraries="`echo '' $site_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac -case "$site_prefixes" in *:* ) site_prefixes="`echo '' $site_prefixes | sed -e 's/^ //' -e 's/:/ /g'`";; esac -case "$site_runtime_libraries" in *:* ) site_runtime_libraries="`echo '' $site_runtime_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac - test -n "$with_x" && with_x11="$with_x" +if test "$with_purify" = "yes" -o "$with_quantify" = "yes"; then + test "$with_system_malloc" = "default" && with_system_malloc=yes +fi if test -n "$gung_ho"; then test -z "$use_minimal_tagbits" && use_minimal_tagbits="$gung_ho" @@ -715,10 +706,6 @@ elif test "$with_cde" = "yes"; then with_tooltalk=yes fi -if test "$run_in_place" = "yes"; then - echo "configure: warning: "The --run-in-place option is ignored because it is unnecessary."" 1>&2 -fi - case "$srcdir" in "" ) @@ -754,13 +741,8 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 esac if test -z "$configuration"; then - echo $ac_n "checking "host system type"""... $ac_c" 1>&6 -echo "configure:759: checking "host system type"" >&5 - if configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess | \ - sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` ; then - echo "$ac_t""$configuration" 1>&6 - else - echo "$ac_t""unknown" 1>&6 + configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess` + if test -z "$configuration"; then (echo "$progname: Usage error:" echo " " "XEmacs has not been ported to this host type. Try explicitly specifying the CONFIGURATION when rerunning configure." @@ -769,7 +751,7 @@ echo " Use \`$progname --help' to show usage.") >&2 && exit 1 fi echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:773: checking whether ln -s works" >&5 +echo "configure:755: checking whether ln -s works" >&5 rm -f conftestdata if ln -s X conftestdata 2>/dev/null @@ -984,12 +966,13 @@ EOF -echo "checking "the configuration name"" 1>&6 -echo "configure:989: checking "the configuration name"" >&5 +echo $ac_n "checking "host system type"""... $ac_c" 1>&6 +echo "configure:971: checking "host system type"" >&5 internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'` -if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else - exit $? -fi +canonical=`${CONFIG_SHELL-/bin/sh} $srcdir/config.sub "$internal_configuration"` +configuration=`echo "$configuration" | sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` +canonical=`echo "$canonical" | sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` +echo "$ac_t""$configuration" 1>&6 @@ -1012,6 +995,8 @@ case "$canonical" in m68*-sony-* ) machine=news ;; mips-sony-* ) machine=news-risc ;; clipper-* ) machine=clipper ;; + arm-* ) machine=arm ;; + ns32k-* ) machine=ns32000 ;; esac case "$canonical" in @@ -1074,13 +1059,9 @@ case "$canonical" in *-*-openbsd* ) case "${canonical}" in - alpha*-*-openbsd*) machine=alpha ;; i386-*-openbsd*) machine=intel386 ;; m68k-*-openbsd*) machine=hp9000s300 ;; mipsel-*-openbsd*) machine=pmax ;; - ns32k-*-openbsd*) machine=ns32000 ;; - sparc-*-openbsd*) machine=sparc ;; - vax-*-openbsd*) machine=vax ;; esac ;; @@ -1377,8 +1358,6 @@ EOF m68k-*-linux* ) machine=m68k opsys=linux ;; - arm-*-linux* ) machine=arm opsys=linux ;; - esac if test -z "$machine" -o -z "$opsys"; then @@ -1477,7 +1456,7 @@ xe_save_CFLAGS="$CFLAGS" # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1481: checking for $ac_word" >&5 +echo "configure:1460: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1503,7 +1482,7 @@ if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1507: checking for $ac_word" >&5 +echo "configure:1486: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1548,7 +1527,7 @@ fi fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1552: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1531: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1560,11 +1539,11 @@ ac_link='${CC-cc} -o conftest $CFLAGS '"$xe_cppflags $xe_ldflags"' conftest.$ac_ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1547: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1584,19 +1563,19 @@ if test $ac_cv_prog_cc_works = no; then { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1588: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1567: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1593: checking whether we are using GNU C" >&5 +echo "configure:1572: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1579: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1610,7 +1589,7 @@ if test $ac_cv_prog_gcc = yes; then ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1614: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1593: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1639,7 +1618,7 @@ if test "$with_gcc" = "no" -a "$GCC" = "yes"; then # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1643: checking for $ac_word" >&5 +echo "configure:1622: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1665,7 +1644,7 @@ if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1669: checking for $ac_word" >&5 +echo "configure:1648: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1710,7 +1689,7 @@ fi fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1714: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1693: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1722,11 +1701,11 @@ ac_link='${CC-cc} -o conftest $CFLAGS '"$xe_cppflags $xe_ldflags"' conftest.$ac_ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1709: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1746,19 +1725,19 @@ if test $ac_cv_prog_cc_works = no; then { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1750: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1729: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1755: checking whether we are using GNU C" >&5 +echo "configure:1734: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1741: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1772,7 +1751,7 @@ if test $ac_cv_prog_gcc = yes; then ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1776: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1755: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1801,7 +1780,7 @@ elif test "$with_gcc" = "yes" -a "$GCC" != "yes" ; then # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1805: checking for $ac_word" >&5 +echo "configure:1784: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1827,7 +1806,7 @@ if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1831: checking for $ac_word" >&5 +echo "configure:1810: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1872,7 +1851,7 @@ fi fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1876: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1855: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1884,11 +1863,11 @@ ac_link='${CC-cc} -o conftest $CFLAGS '"$xe_cppflags $xe_ldflags"' conftest.$ac_ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1871: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1908,19 +1887,19 @@ if test $ac_cv_prog_cc_works = no; then { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1912: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1891: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1917: checking whether we are using GNU C" >&5 +echo "configure:1896: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1903: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1934,7 +1913,7 @@ if test $ac_cv_prog_gcc = yes; then ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1938: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1917: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1967,7 +1946,7 @@ test -n "$CPP" -a -d "$CPP" && CPP= test -n "$NON_GNU_CPP" -a "$GCC" != "yes" -a -z "$CPP" && CPP="$NON_GNU_CPP" echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:1971: checking how to run the C preprocessor" >&5 +echo "configure:1950: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -1980,13 +1959,13 @@ if test -z "$CPP"; then # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1990: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:1969: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -1997,13 +1976,13 @@ else rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2007: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:1986: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2026,9 +2005,9 @@ echo "$ac_t""$CPP" 1>&6 echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:2030: checking for AIX" >&5 +echo "configure:2009: checking for AIX" >&5 cat > conftest.$ac_ext <&6 -echo "configure:2059: checking for GNU libc" >&5 +echo "configure:2038: checking for GNU libc" >&5 cat > conftest.$ac_ext < int main() { @@ -2069,7 +2048,7 @@ int main() { ; return 0; } EOF -if { (eval echo configure:2073: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2052: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* have_glibc=yes else @@ -2091,7 +2070,7 @@ EOF cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:2086: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then : else @@ -2278,7 +2257,7 @@ configure___ mail_use_lockf=no EOF -CPP=`eval "echo $CPP"` +CPP=`eval "echo $CPP $CPPFLAGS"` eval `$CPP -Isrc $tempcname \ | sed -n -e "s/[ ]*=[ \"]*/='/" -e "s/[ \"]*\$/'/" -e "s/^configure___//p"` @@ -2314,8 +2293,8 @@ if test "$GCC" = "yes"; then set x $ld_switch_system; shift; ld_switch_system="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_system="$ld_switch_system $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_system="$ld_switch_system $1" ;; + -L | -l | -u ) ld_switch_system="$ld_switch_system $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_system="$ld_switch_system $1" ;; -Xlinker* ) ;; * ) ld_switch_system="$ld_switch_system -Xlinker $1" ;; esac @@ -2327,8 +2306,8 @@ if test "$GCC" = "yes"; then set x $ld_switch_machine; shift; ld_switch_machine="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_machine="$ld_switch_machine $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_machine="$ld_switch_machine $1" ;; + -L | -l | -u ) ld_switch_machine="$ld_switch_machine $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_machine="$ld_switch_machine $1" ;; -Xlinker* ) ;; * ) ld_switch_machine="$ld_switch_machine -Xlinker $1" ;; esac @@ -2340,8 +2319,8 @@ if test "$GCC" = "yes"; then set x $LDFLAGS; shift; LDFLAGS="" while test -n "$1"; do case $1 in - -L | -l | -u ) LDFLAGS="$LDFLAGS $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) LDFLAGS="$LDFLAGS $1" ;; + -L | -l | -u ) LDFLAGS="$LDFLAGS $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) LDFLAGS="$LDFLAGS $1" ;; -Xlinker* ) ;; * ) LDFLAGS="$LDFLAGS -Xlinker $1" ;; esac @@ -2353,8 +2332,8 @@ if test "$GCC" = "yes"; then set x $ld_call_shared; shift; ld_call_shared="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_call_shared="$ld_call_shared $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_call_shared="$ld_call_shared $1" ;; + -L | -l | -u ) ld_call_shared="$ld_call_shared $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_call_shared="$ld_call_shared $1" ;; -Xlinker* ) ;; * ) ld_call_shared="$ld_call_shared -Xlinker $1" ;; esac @@ -2373,7 +2352,7 @@ test -n "$unexec" && extra_objs="$extra_objs $unexec" && if test "$ext fi echo $ac_n "checking for dynodump""... $ac_c" 1>&6 -echo "configure:2377: checking for dynodump" >&5 +echo "configure:2356: checking for dynodump" >&5 if test "$unexec" != "unexsol2.o"; then echo "$ac_t""no" 1>&6 else @@ -2411,12 +2390,12 @@ if test "$unexec" = "unexaix.o"; then done echo $ac_n "checking for terminateAndUnload in -lC""... $ac_c" 1>&6 -echo "configure:2415: checking for terminateAndUnload in -lC" >&5 +echo "configure:2394: checking for terminateAndUnload in -lC" >&5 ac_lib_var=`echo C'_'terminateAndUnload | sed 'y%./+-%__p_%'` xe_check_libs=" -lC " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2410: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -2465,36 +2444,56 @@ test "$GCC" != "yes" && lib_gcc= -if test -n "$site_prefixes"; then - for arg in $site_prefixes; do - case "$arg" in - -* ) ;; - * ) argi="-I${arg}/include" ; argl="-L${arg}/lib" ;; - esac - c_switch_site="$c_switch_site $argi" && if test "$extra_verbose" = "yes"; then echo " Appending \"$argi\" to \$c_switch_site"; fi - ld_switch_site="$ld_switch_site $argl" && if test "$extra_verbose" = "yes"; then echo " Appending \"$argl\" to \$ld_switch_site"; fi - done -fi - +case "$site_libraries" in *:* ) site_libraries="`echo '' $site_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac if test -n "$site_libraries"; then for arg in $site_libraries; do - case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + { echo "Invalid site library \`$arg': no such directory" >&2; exit 1; } + arg="-L${arg}" ;; + esac ld_switch_site="$ld_switch_site $arg" && if test "$extra_verbose" = "yes"; then echo " Appending \"$arg\" to \$ld_switch_site"; fi done fi +case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac if test -n "$site_includes"; then for arg in $site_includes; do - case "$arg" in -* ) ;; * ) arg="-I${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + { echo "Invalid site include \`$arg': no such directory" >&2; exit 1; } + arg="-I${arg}" ;; + esac c_switch_site="$c_switch_site $arg" && if test "$extra_verbose" = "yes"; then echo " Appending \"$arg\" to \$c_switch_site"; fi done fi +case "$site_prefixes" in *:* ) site_prefixes="`echo '' $site_prefixes | sed -e 's/^ //' -e 's/:/ /g'`";; esac +if test -n "$site_prefixes"; then + for dir in $site_prefixes; do + inc_dir="${dir}/include" + lib_dir="${dir}/lib" + if test ! -d "$dir"; then + { echo "Invalid site prefix \`$dir': no such directory" >&2; exit 1; } + elif test ! -d "$inc_dir"; then + { echo "Invalid site prefix \`$dir': no such directory \`$inc_dir'" >&2; exit 1; } + elif test ! -d "$lib_dir"; then + { echo "Invalid site prefix \`$dir': no such directory \`$lib_dir'" >&2; exit 1; } + else + c_switch_site="$c_switch_site "-I$inc_dir"" && if test "$extra_verbose" = "yes"; then echo " Appending \""-I$inc_dir"\" to \$c_switch_site"; fi + ld_switch_site="$ld_switch_site "-L$lib_dir"" && if test "$extra_verbose" = "yes"; then echo " Appending \""-L$lib_dir"\" to \$ld_switch_site"; fi + fi + done +fi + for dir in "/usr/ccs/lib"; do test -d "$dir" && ld_switch_site="$ld_switch_site -L${dir}" && if test "$extra_verbose" = "yes"; then echo " Appending \"-L${dir}\" to \$ld_switch_site"; fi done +case "$site_runtime_libraries" in *:* ) site_runtime_libraries="`echo '' $site_runtime_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac if test -n "$site_runtime_libraries"; then LD_RUN_PATH="`echo $site_runtime_libraries | sed -e 's/ */:/g'`" export LD_RUN_PATH @@ -2511,7 +2510,7 @@ fi if test "$add_runtime_path" = "yes"; then echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6 -echo "configure:2515: checking "for runtime libraries flag"" >&5 +echo "configure:2514: checking "for runtime libraries flag"" >&5 case "$opsys" in sol2 ) dash_r="-R" ;; decosf* | linux* ) dash_r="-rpath " ;; @@ -2524,8 +2523,8 @@ if test "$GCC" = "yes"; then set x $xe_check_libs; shift; xe_check_libs="" while test -n "$1"; do case $1 in - -L | -l | -u ) xe_check_libs="$xe_check_libs $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) xe_check_libs="$xe_check_libs $1" ;; + -L | -l | -u ) xe_check_libs="$xe_check_libs $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) xe_check_libs="$xe_check_libs $1" ;; -Xlinker* ) ;; * ) xe_check_libs="$xe_check_libs -Xlinker $1" ;; esac @@ -2533,14 +2532,14 @@ if test "$GCC" = "yes"; then done fi cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* dash_r="$try_dash_r" else @@ -2619,8 +2618,8 @@ if test "$GCC" = "yes"; then set x $ld_switch_run; shift; ld_switch_run="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;; + -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;; -Xlinker* ) ;; * ) ld_switch_run="$ld_switch_run -Xlinker $1" ;; esac @@ -2641,10 +2640,10 @@ else fi after_morecore_hook_exists=yes echo $ac_n "checking for malloc_get_state""... $ac_c" 1>&6 -echo "configure:2645: checking for malloc_get_state" >&5 +echo "configure:2644: checking for malloc_get_state" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2670: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_malloc_get_state=yes" else @@ -2687,10 +2686,10 @@ doug_lea_malloc=no fi echo $ac_n "checking for malloc_set_state""... $ac_c" 1>&6 -echo "configure:2691: checking for malloc_set_state" >&5 +echo "configure:2690: checking for malloc_set_state" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2716: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_malloc_set_state=yes" else @@ -2733,16 +2732,16 @@ doug_lea_malloc=no fi echo $ac_n "checking whether __after_morecore_hook exists""... $ac_c" 1>&6 -echo "configure:2737: checking whether __after_morecore_hook exists" >&5 +echo "configure:2736: checking whether __after_morecore_hook exists" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2745: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 else @@ -2801,7 +2800,7 @@ fi # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2805: checking for $ac_word" >&5 +echo "configure:2804: checking for $ac_word" >&5 if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. @@ -2854,7 +2853,7 @@ ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:2858: checking for a BSD compatible install" >&5 +echo "configure:2857: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" @@ -2905,7 +2904,7 @@ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2909: checking for $ac_word" >&5 +echo "configure:2908: checking for $ac_word" >&5 if test -n "$YACC"; then ac_cv_prog_YACC="$YACC" # Let the user override the test. @@ -2936,15 +2935,15 @@ for ac_hdr in mach/mach.h sys/stropts.h sys/timeb.h sys/time.h unistd.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2940: checking for $ac_hdr" >&5 +echo "configure:2939: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2948: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2947: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2977,15 +2976,15 @@ for ac_hdr in utime.h locale.h libgen.h fcntl.h ulimit.h cygwin/version.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:2981: checking for $ac_hdr" >&5 +echo "configure:2980: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2989: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2988: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3014,19 +3013,19 @@ else fi done -for ac_hdr in linux/version.h kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h +for ac_hdr in kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:3022: checking for $ac_hdr" >&5 +echo "configure:3021: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:3030: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:3029: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3056,10 +3055,10 @@ fi done echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:3060: checking for sys/wait.h that is POSIX.1 compatible" >&5 +echo "configure:3059: checking for sys/wait.h that is POSIX.1 compatible" >&5 cat > conftest.$ac_ext < #include @@ -3075,7 +3074,7 @@ wait (&s); s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } EOF -if { (eval echo configure:3079: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3078: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_sys_wait_h=yes else @@ -3099,10 +3098,10 @@ EOF fi echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:3103: checking for ANSI C header files" >&5 +echo "configure:3102: checking for ANSI C header files" >&5 cat > conftest.$ac_ext < #include @@ -3110,7 +3109,7 @@ cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:3114: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:3113: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3127,7 +3126,7 @@ rm -f conftest* if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -3145,7 +3144,7 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -3163,7 +3162,7 @@ fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -3174,7 +3173,7 @@ if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } EOF -if { (eval echo configure:3178: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3177: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then : else @@ -3200,10 +3199,10 @@ EOF fi echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:3204: checking whether time.h and sys/time.h may both be included" >&5 +echo "configure:3203: checking whether time.h and sys/time.h may both be included" >&5 cat > conftest.$ac_ext < #include @@ -3212,7 +3211,7 @@ int main() { struct tm *tp; ; return 0; } EOF -if { (eval echo configure:3216: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3215: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -3236,10 +3235,10 @@ EOF fi echo $ac_n "checking for sys_siglist declaration in signal.h or unistd.h""... $ac_c" 1>&6 -echo "configure:3240: checking for sys_siglist declaration in signal.h or unistd.h" >&5 +echo "configure:3239: checking for sys_siglist declaration in signal.h or unistd.h" >&5 cat > conftest.$ac_ext < #include @@ -3251,7 +3250,7 @@ int main() { char *msg = *(sys_siglist + 1); ; return 0; } EOF -if { (eval echo configure:3255: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3254: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_decl_sys_siglist=yes else @@ -3276,9 +3275,9 @@ fi echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6 -echo "configure:3280: checking for struct utimbuf" >&5 +echo "configure:3279: checking for struct utimbuf" >&5 cat > conftest.$ac_ext < @@ -3297,7 +3296,7 @@ int main() { static struct utimbuf x; x.actime = x.modtime; ; return 0; } EOF -if { (eval echo configure:3301: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3300: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -3317,10 +3316,10 @@ fi rm -f conftest* echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:3321: checking return type of signal handlers" >&5 +echo "configure:3320: checking return type of signal handlers" >&5 cat > conftest.$ac_ext < #include @@ -3337,7 +3336,7 @@ int main() { int i; ; return 0; } EOF -if { (eval echo configure:3341: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3340: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -3359,10 +3358,10 @@ EOF echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:3363: checking for size_t" >&5 +echo "configure:3362: checking for size_t" >&5 cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3393,10 +3392,10 @@ EOF fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:3397: checking for pid_t" >&5 +echo "configure:3396: checking for pid_t" >&5 cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3427,10 +3426,10 @@ EOF fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:3431: checking for uid_t in sys/types.h" >&5 +echo "configure:3430: checking for uid_t in sys/types.h" >&5 cat > conftest.$ac_ext < EOF @@ -3466,10 +3465,10 @@ EOF fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:3470: checking for mode_t" >&5 +echo "configure:3469: checking for mode_t" >&5 cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3500,10 +3499,10 @@ EOF fi echo $ac_n "checking for off_t""... $ac_c" 1>&6 -echo "configure:3504: checking for off_t" >&5 +echo "configure:3503: checking for off_t" >&5 cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3535,9 +3534,9 @@ fi echo $ac_n "checking for struct timeval""... $ac_c" 1>&6 -echo "configure:3539: checking for struct timeval" >&5 +echo "configure:3538: checking for struct timeval" >&5 cat > conftest.$ac_ext < @@ -3553,7 +3552,7 @@ int main() { static struct timeval x; x.tv_sec = x.tv_usec; ; return 0; } EOF -if { (eval echo configure:3557: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3556: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 HAVE_TIMEVAL=yes @@ -3575,10 +3574,10 @@ fi rm -f conftest* echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 -echo "configure:3579: checking whether struct tm is in sys/time.h or time.h" >&5 +echo "configure:3578: checking whether struct tm is in sys/time.h or time.h" >&5 cat > conftest.$ac_ext < #include @@ -3586,7 +3585,7 @@ int main() { struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:3590: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3589: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -3610,10 +3609,10 @@ EOF fi echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6 -echo "configure:3614: checking for tm_zone in struct tm" >&5 +echo "configure:3613: checking for tm_zone in struct tm" >&5 cat > conftest.$ac_ext < #include <$ac_cv_struct_tm> @@ -3621,7 +3620,7 @@ int main() { struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:3625: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3624: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -3644,10 +3643,10 @@ EOF else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:3648: checking for tzname" >&5 +echo "configure:3647: checking for tzname" >&5 cat > conftest.$ac_ext < #ifndef tzname /* For SGI. */ @@ -3657,7 +3656,7 @@ int main() { atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:3661: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3660: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -3683,10 +3682,10 @@ fi echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:3687: checking for working const" >&5 +echo "configure:3686: checking for working const" >&5 cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3738: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3760,7 +3759,7 @@ fi echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:3764: checking whether ${MAKE-make} sets \${MAKE}" >&5 +echo "configure:3763: checking whether ${MAKE-make} sets \${MAKE}" >&5 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` cat > conftestmake <<\EOF @@ -3785,12 +3784,12 @@ fi echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:3789: checking whether byte ordering is bigendian" >&5 +echo "configure:3788: checking whether byte ordering is bigendian" >&5 ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext < #include @@ -3801,11 +3800,11 @@ int main() { #endif ; return 0; } EOF -if { (eval echo configure:3805: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3804: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext < #include @@ -3816,7 +3815,7 @@ int main() { #endif ; return 0; } EOF -if { (eval echo configure:3820: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3819: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -3833,7 +3832,7 @@ fi rm -f conftest* if test $ac_cv_c_bigendian = unknown; then cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3849: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_c_bigendian=no else @@ -3873,10 +3872,10 @@ fi echo $ac_n "checking size of short""... $ac_c" 1>&6 -echo "configure:3877: checking size of short" >&5 +echo "configure:3876: checking size of short" >&5 cat > conftest.$ac_ext < main() @@ -3887,7 +3886,7 @@ main() exit(0); } EOF -if { (eval echo configure:3891: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_short=`cat conftestval` else @@ -3915,10 +3914,10 @@ if test "$ac_cv_sizeof_short" = 0; then exit 1 fi echo $ac_n "checking size of int""... $ac_c" 1>&6 -echo "configure:3919: checking size of int" >&5 +echo "configure:3918: checking size of int" >&5 cat > conftest.$ac_ext < main() @@ -3929,7 +3928,7 @@ main() exit(0); } EOF -if { (eval echo configure:3933: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3932: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_int=`cat conftestval` else @@ -3951,10 +3950,10 @@ EOF echo $ac_n "checking size of long""... $ac_c" 1>&6 -echo "configure:3955: checking size of long" >&5 +echo "configure:3954: checking size of long" >&5 cat > conftest.$ac_ext < main() @@ -3965,7 +3964,7 @@ main() exit(0); } EOF -if { (eval echo configure:3969: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3968: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_long=`cat conftestval` else @@ -3987,10 +3986,10 @@ EOF echo $ac_n "checking size of long long""... $ac_c" 1>&6 -echo "configure:3991: checking size of long long" >&5 +echo "configure:3990: checking size of long long" >&5 cat > conftest.$ac_ext < main() @@ -4001,7 +4000,7 @@ main() exit(0); } EOF -if { (eval echo configure:4005: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:4004: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_long_long=`cat conftestval` else @@ -4023,10 +4022,10 @@ EOF echo $ac_n "checking size of void *""... $ac_c" 1>&6 -echo "configure:4027: checking size of void *" >&5 +echo "configure:4026: checking size of void *" >&5 cat > conftest.$ac_ext < main() @@ -4037,7 +4036,7 @@ main() exit(0); } EOF -if { (eval echo configure:4041: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:4040: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_void_p=`cat conftestval` else @@ -4060,7 +4059,7 @@ EOF echo $ac_n "checking for long file names""... $ac_c" 1>&6 -echo "configure:4064: checking for long file names" >&5 +echo "configure:4063: checking for long file names" >&5 ac_cv_sys_long_file_names=yes # Test for long file names in all the places we know might matter: @@ -4107,12 +4106,12 @@ fi echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 -echo "configure:4111: checking for sin in -lm" >&5 +echo "configure:4110: checking for sin in -lm" >&5 ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` xe_check_libs=" -lm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4126: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4165,14 +4164,14 @@ EOF cat > conftest.$ac_ext < int main() { return atanh(1.0) + asinh(1.0) + acosh(1.0); ; return 0; } EOF -if { (eval echo configure:4176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4175: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_INVERSE_HYPERBOLIC @@ -4189,7 +4188,7 @@ fi rm -f conftest* echo "checking type of mail spool file locking" 1>&6 -echo "configure:4193: checking type of mail spool file locking" >&5 +echo "configure:4192: checking type of mail spool file locking" >&5 test -z "$mail_locking" -a "$mail_use_flock" = "yes" && mail_locking=flock test -z "$mail_locking" -a "$mail_use_lockf" = "yes" && mail_locking=lockf if test "$mail_locking" = "lockf"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -4213,12 +4212,12 @@ fi echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6 -echo "configure:4217: checking for kstat_open in -lkstat" >&5 +echo "configure:4216: checking for kstat_open in -lkstat" >&5 ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lkstat " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4263,12 +4262,12 @@ fi echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6 -echo "configure:4267: checking for kvm_read in -lkvm" >&5 +echo "configure:4266: checking for kvm_read in -lkvm" >&5 ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'` xe_check_libs=" -lkvm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4282: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4314,12 +4313,12 @@ fi case "$opsys" in decosf*) echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6 -echo "configure:4318: checking for cma_open in -lpthreads" >&5 +echo "configure:4317: checking for cma_open in -lpthreads" >&5 ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lpthreads " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4333: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4366,7 +4365,7 @@ fi esac echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6 -echo "configure:4370: checking whether the -xildoff compiler flag is required" >&5 +echo "configure:4369: checking whether the -xildoff compiler flag is required" >&5 if ${CC-cc} '-###' -xildon no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then if ${CC-cc} '-###' -xildoff no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then echo "$ac_t""no" 1>&6; @@ -4377,7 +4376,7 @@ fi if test "$opsys" = "sol2" && test "$OS_RELEASE" -ge 56; then echo $ac_n "checking for \"-z ignore\" linker flag""... $ac_c" 1>&6 -echo "configure:4381: checking for \"-z ignore\" linker flag" >&5 +echo "configure:4380: checking for \"-z ignore\" linker flag" >&5 case "`ld -h 2>&1`" in *-z\ ignore\|record* ) echo "$ac_t""yes" 1>&6 ld_switch_site="-z ignore $ld_switch_site" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-z ignore\" to \$ld_switch_site"; fi ;; @@ -4387,7 +4386,7 @@ fi echo "checking "for specified window system"" 1>&6 -echo "configure:4391: checking "for specified window system"" >&5 +echo "configure:4390: checking "for specified window system"" >&5 if test "$with_x11" != "no"; then test "$x_includes $x_libraries" != "NONE NONE" && \ @@ -4420,7 +4419,7 @@ if test "$with_x11" != "no"; then # Uses ac_ vars as temps to allow command line to override cache and checks. # --without-x overrides everything else, but does not touch the cache. echo $ac_n "checking for X""... $ac_c" 1>&6 -echo "configure:4424: checking for X" >&5 +echo "configure:4423: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -4480,12 +4479,12 @@ if test "$ac_x_includes" = NO; then # First, try using that file with no special directory specified. cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:4488: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4554,14 +4553,14 @@ if test "$ac_x_libraries" = NO; then ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4564: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* LIBS="$ac_save_LIBS" # We can link X programs with no special library path. @@ -4670,17 +4669,17 @@ else case "`(uname -sr) 2>/dev/null`" in "SunOS 5"*) echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6 -echo "configure:4674: checking whether -R must be followed by a space" >&5 +echo "configure:4673: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -4696,14 +4695,14 @@ rm -f conftest* else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4706: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -4739,12 +4738,12 @@ ac_cv_lib_dnet_dnet_ntoa=no else echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:4743: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:4742: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4779,12 +4778,12 @@ fi if test $ac_cv_lib_dnet_dnet_ntoa = no; then echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6 -echo "configure:4783: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:4782: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet_stub " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4824,10 +4823,10 @@ fi # The nsl library prevents programs from opening the X display # on Irix 5.2, according to dickey@clark.net. echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6 -echo "configure:4828: checking for gethostbyname" >&5 +echo "configure:4827: checking for gethostbyname" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4853: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -4871,12 +4870,12 @@ fi if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:4875: checking for gethostbyname in -lnsl" >&5 +echo "configure:4874: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` xe_check_libs=" -lnsl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4917,10 +4916,10 @@ fi # -lsocket must be given before -lnsl if both are needed. # We assume that if connect needs -lnsl, so does gethostbyname. echo $ac_n "checking for connect""... $ac_c" 1>&6 -echo "configure:4921: checking for connect" >&5 +echo "configure:4920: checking for connect" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4946: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -4966,12 +4965,12 @@ fi xe_msg_checking="for connect in -lsocket" test -n "$X_EXTRA_LIBS" && xe_msg_checking="$xe_msg_checking using extra libs $X_EXTRA_LIBS" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:4970: checking "$xe_msg_checking"" >&5 +echo "configure:4969: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocket $X_EXTRA_LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4985: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5006,10 +5005,10 @@ fi # gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX. echo $ac_n "checking for remove""... $ac_c" 1>&6 -echo "configure:5010: checking for remove" >&5 +echo "configure:5009: checking for remove" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5035: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -5053,12 +5052,12 @@ fi if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:5057: checking for remove in -lposix" >&5 +echo "configure:5056: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` xe_check_libs=" -lposix " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5093,10 +5092,10 @@ fi # BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay. echo $ac_n "checking for shmat""... $ac_c" 1>&6 -echo "configure:5097: checking for shmat" >&5 +echo "configure:5096: checking for shmat" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5122: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -5140,12 +5139,12 @@ fi if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:5144: checking for shmat in -lipc" >&5 +echo "configure:5143: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` xe_check_libs=" -lipc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5159: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5190,12 +5189,12 @@ fi # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:5194: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:5193: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` xe_check_libs=" -lICE " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5209: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5334,8 +5333,8 @@ if test "$GCC" = "yes"; then set x $ld_switch_run; shift; ld_switch_run="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;; + -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;; -Xlinker* ) ;; * ) ld_switch_run="$ld_switch_run -Xlinker $1" ;; esac @@ -5375,7 +5374,7 @@ EOF echo "checking for X defines extracted by xmkmf" 1>&6 -echo "configure:5379: checking for X defines extracted by xmkmf" >&5 +echo "configure:5378: checking for X defines extracted by xmkmf" >&5 rm -fr conftestdir if mkdir conftestdir; then cd conftestdir @@ -5407,15 +5406,15 @@ EOF ac_safe=`echo "X11/Intrinsic.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Intrinsic.h""... $ac_c" 1>&6 -echo "configure:5411: checking for X11/Intrinsic.h" >&5 +echo "configure:5410: checking for X11/Intrinsic.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5419: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5418: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5439,12 +5438,12 @@ fi echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6 -echo "configure:5443: checking for XOpenDisplay in -lX11" >&5 +echo "configure:5442: checking for XOpenDisplay in -lX11" >&5 ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5458: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5480,12 +5479,12 @@ fi xe_msg_checking="for XGetFontProperty in -lX11" test -n "-b i486-linuxaout" && xe_msg_checking="$xe_msg_checking using extra libs -b i486-linuxaout" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5484: checking "$xe_msg_checking"" >&5 +echo "configure:5483: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 -b i486-linuxaout" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5499: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5523,12 +5522,12 @@ fi echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6 -echo "configure:5527: checking for XShapeSelectInput in -lXext" >&5 +echo "configure:5526: checking for XShapeSelectInput in -lXext" >&5 ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'` xe_check_libs=" -lXext " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5542: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5562,12 +5561,12 @@ fi echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6 -echo "configure:5566: checking for XtOpenDisplay in -lXt" >&5 +echo "configure:5565: checking for XtOpenDisplay in -lXt" >&5 ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lXt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5581: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5601,14 +5600,14 @@ fi echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6 -echo "configure:5605: checking the version of X11 being used" >&5 +echo "configure:5604: checking the version of X11 being used" >&5 cat > conftest.$ac_ext < int main(int c, char *v[]) { return c>1 ? XlibSpecificationRelease : 0; } EOF -if { (eval echo configure:5612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:5611: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ./conftest foobar; x11_release=$? else @@ -5633,15 +5632,15 @@ EOF do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:5637: checking for $ac_hdr" >&5 +echo "configure:5636: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5644: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5672,7 +5671,7 @@ done echo $ac_n "checking for XFree86""... $ac_c" 1>&6 -echo "configure:5676: checking for XFree86" >&5 +echo "configure:5675: checking for XFree86" >&5 if test -d "/usr/X386/include" -o \ -f "/etc/XF86Config" -o \ -f "/etc/X11/XF86Config" -o \ @@ -5692,12 +5691,12 @@ EOF test -z "$with_xmu" && { echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6 -echo "configure:5696: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 +echo "configure:5695: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'` xe_check_libs=" -lXmu " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5747,19 +5746,19 @@ EOF echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6 -echo "configure:5751: checking for main in -lXbsd" >&5 +echo "configure:5750: checking for main in -lXbsd" >&5 ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lXbsd " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5762: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5796,22 +5795,22 @@ fi fi if test "$with_msw" != "no"; then echo "checking for MS-Windows" 1>&6 -echo "configure:5800: checking for MS-Windows" >&5 +echo "configure:5799: checking for MS-Windows" >&5 echo $ac_n "checking for main in -lgdi32""... $ac_c" 1>&6 -echo "configure:5803: checking for main in -lgdi32" >&5 +echo "configure:5802: checking for main in -lgdi32" >&5 ac_lib_var=`echo gdi32'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdi32 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5814: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5862,7 +5861,7 @@ EOF echo " xemacs will be linked with \"dialog-msw.o\"" fi else - test "$with_scrollbars" != "no" && extra_objs="$extra_objs scrollbar-msw.o" && if test "$extra_verbose" = "yes"; then + test "$with_scrollbars" != "no" && extra_objs="$extra_objs scrollbar-msw.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"scrollbar-msw.o\"" fi test "$with_menubars" != "no" && extra_objs="$extra_objs menubar-msw.o" && if test "$extra_verbose" = "yes"; then @@ -5871,17 +5870,17 @@ EOF test "$with_toolbars" != "no" && extra_objs="$extra_objs toolbar-msw.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"toolbar-msw.o\"" fi - test "$with_dialogs" != "no" && extra_objs="$extra_objs dialog-msw.o" && if test "$extra_verbose" = "yes"; then + test "$with_dialogs" != "no" && extra_objs="$extra_objs dialog-msw.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"dialog-msw.o\"" fi fi cat > conftest.$ac_ext < int main() { return (open("/dev/windows", O_RDONLY, 0) > 0)? 0 : 1; } EOF -if { (eval echo configure:5885: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:5884: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_MSG_SELECT @@ -5960,7 +5959,7 @@ case "$x_libraries" in *X11R4* ) esac echo "checking for session-management option" 1>&6 -echo "configure:5964: checking for session-management option" >&5; +echo "configure:5963: checking for session-management option" >&5; if test "$with_session" != "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SESSION @@ -5975,15 +5974,15 @@ fi test -z "$with_xauth" && test "$window_system" = "none" && with_xauth=no test -z "$with_xauth" && { ac_safe=`echo "X11/Xauth.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for X11/Xauth.h""... $ac_c" 1>&6 -echo "configure:5979: checking for X11/Xauth.h" >&5 +echo "configure:5978: checking for X11/Xauth.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5987: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5986: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6006,12 +6005,12 @@ fi } test -z "$with_xauth" && { echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6 -echo "configure:6010: checking for XauGetAuthByAddr in -lXau" >&5 +echo "configure:6009: checking for XauGetAuthByAddr in -lXau" >&5 ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'` xe_check_libs=" -lXau " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6025: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6067,15 +6066,15 @@ if test "$with_tooltalk" != "no" ; then for dir in "" "Tt/" "desktop/" ; do ac_safe=`echo "${dir}tt_c.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}tt_c.h""... $ac_c" 1>&6 -echo "configure:6071: checking for ${dir}tt_c.h" >&5 +echo "configure:6070: checking for ${dir}tt_c.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6079: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6078: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6111,12 +6110,12 @@ if test "$with_tooltalk" != "no" ; then xe_msg_checking="for tt_message_create in -ltt" test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6115: checking "$xe_msg_checking"" >&5 +echo "configure:6114: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'` xe_check_libs=" -ltt $extra_libs" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6130: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6184,15 +6183,15 @@ fi test -z "$with_cde" && { ac_safe=`echo "Dt/Dt.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Dt/Dt.h""... $ac_c" 1>&6 -echo "configure:6188: checking for Dt/Dt.h" >&5 +echo "configure:6187: checking for Dt/Dt.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6196: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6195: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6215,12 +6214,12 @@ fi } test -z "$with_cde" && { echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6 -echo "configure:6219: checking for DtDndDragStart in -lDtSvc" >&5 +echo "configure:6218: checking for DtDndDragStart in -lDtSvc" >&5 ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'` xe_check_libs=" -lDtSvc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6234: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6300,7 +6299,7 @@ EOF fi echo $ac_n "checking if drag and drop API is needed""... $ac_c" 1>&6 -echo "configure:6304: checking if drag and drop API is needed" >&5 +echo "configure:6303: checking if drag and drop API is needed" >&5 if test "$with_dragndrop" != "no" ; then if test -n "$dragndrop_proto" ; then with_dragndrop=yes @@ -6321,18 +6320,18 @@ EOF fi echo "checking for LDAP" 1>&6 -echo "configure:6325: checking for LDAP" >&5 +echo "configure:6324: checking for LDAP" >&5 test -z "$with_ldap" && { ac_safe=`echo "ldap.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ldap.h""... $ac_c" 1>&6 -echo "configure:6328: checking for ldap.h" >&5 +echo "configure:6327: checking for ldap.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6336: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6335: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6355,15 +6354,15 @@ fi } test -z "$with_ldap" && { ac_safe=`echo "lber.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for lber.h""... $ac_c" 1>&6 -echo "configure:6359: checking for lber.h" >&5 +echo "configure:6358: checking for lber.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6367: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6366: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6389,12 +6388,12 @@ if test "$with_ldap" != "no"; then xe_msg_checking="for ldap_open in -lldap" test -n "-llber" && xe_msg_checking="$xe_msg_checking using extra libs -llber" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6393: checking "$xe_msg_checking"" >&5 +echo "configure:6392: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo ldap'_'ldap_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lldap -llber" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6428,12 +6427,12 @@ fi } test "$with_umich_ldap" = "no" && { echo $ac_n "checking for ldap_set_option in -lldap10""... $ac_c" 1>&6 -echo "configure:6432: checking for ldap_set_option in -lldap10" >&5 +echo "configure:6431: checking for ldap_set_option in -lldap10" >&5 ac_lib_var=`echo ldap10'_'ldap_set_option | sed 'y%./+-%__p_%'` xe_check_libs=" -lldap10 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6447: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6508,15 +6507,15 @@ fi if test "$window_system" != "none"; then echo "checking for graphics libraries" 1>&6 -echo "configure:6512: checking for graphics libraries" >&5 +echo "configure:6511: checking for graphics libraries" >&5 xpm_problem="" if test -z "$with_xpm"; then echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6 -echo "configure:6517: checking for Xpm - no older than 3.4f" >&5 +echo "configure:6516: checking for Xpm - no older than 3.4f" >&5 xe_check_libs=-lXpm cat > conftest.$ac_ext < int main(int c, char **v) { @@ -6524,7 +6523,7 @@ echo "configure:6517: checking for Xpm - no older than 3.4f" >&5 XpmIncludeVersion != XpmLibraryVersion() ? 1 : XpmIncludeVersion < 30406 ? 2 : 0 ;} EOF -if { (eval echo configure:6528: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:6527: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ./conftest dummy_arg; xpm_status=$?; if test "$xpm_status" = "0"; then @@ -6566,17 +6565,17 @@ EOF libs_x="-lXpm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXpm\" to \$libs_x"; fi echo $ac_n "checking for \"FOR_MSW\" xpm""... $ac_c" 1>&6 -echo "configure:6570: checking for \"FOR_MSW\" xpm" >&5 +echo "configure:6569: checking for \"FOR_MSW\" xpm" >&5 xe_check_libs=-lXpm cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6579: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* xpm_for_msw=no else @@ -6618,12 +6617,12 @@ EOF if test "$with_png $with_tiff" != "no no"; then echo $ac_n "checking for inflate in -lc""... $ac_c" 1>&6 -echo "configure:6622: checking for inflate in -lc" >&5 +echo "configure:6621: checking for inflate in -lc" >&5 ac_lib_var=`echo c'_'inflate | sed 'y%./+-%__p_%'` xe_check_libs=" -lc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6637: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6653,12 +6652,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for inflate in -lz""... $ac_c" 1>&6 -echo "configure:6657: checking for inflate in -lz" >&5 +echo "configure:6656: checking for inflate in -lz" >&5 ac_lib_var=`echo z'_'inflate | sed 'y%./+-%__p_%'` xe_check_libs=" -lz " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6672: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6688,12 +6687,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for inflate in -lgz""... $ac_c" 1>&6 -echo "configure:6692: checking for inflate in -lgz" >&5 +echo "configure:6691: checking for inflate in -lgz" >&5 ac_lib_var=`echo gz'_'inflate | sed 'y%./+-%__p_%'` xe_check_libs=" -lgz " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6707: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6734,15 +6733,15 @@ fi test -z "$with_jpeg" && { ac_safe=`echo "jpeglib.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for jpeglib.h""... $ac_c" 1>&6 -echo "configure:6738: checking for jpeglib.h" >&5 +echo "configure:6737: checking for jpeglib.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6746: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6745: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6765,12 +6764,12 @@ fi } test -z "$with_jpeg" && { echo $ac_n "checking for jpeg_destroy_decompress in -ljpeg""... $ac_c" 1>&6 -echo "configure:6769: checking for jpeg_destroy_decompress in -ljpeg" >&5 +echo "configure:6768: checking for jpeg_destroy_decompress in -ljpeg" >&5 ac_lib_var=`echo jpeg'_'jpeg_destroy_decompress | sed 'y%./+-%__p_%'` xe_check_libs=" -ljpeg " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6784: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6817,10 +6816,10 @@ EOF png_problem="" test -z "$with_png" && { echo $ac_n "checking for pow""... $ac_c" 1>&6 -echo "configure:6821: checking for pow" >&5 +echo "configure:6820: checking for pow" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6846: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_pow=yes" else @@ -6864,15 +6863,15 @@ fi } test -z "$with_png" && { ac_safe=`echo "png.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for png.h""... $ac_c" 1>&6 -echo "configure:6868: checking for png.h" >&5 +echo "configure:6867: checking for png.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6876: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6875: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6895,12 +6894,12 @@ fi } test -z "$with_png" && { echo $ac_n "checking for png_read_image in -lpng""... $ac_c" 1>&6 -echo "configure:6899: checking for png_read_image in -lpng" >&5 +echo "configure:6898: checking for png_read_image in -lpng" >&5 ac_lib_var=`echo png'_'png_read_image | sed 'y%./+-%__p_%'` xe_check_libs=" -lpng " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6934,10 +6933,10 @@ fi } if test -z "$with_png"; then echo $ac_n "checking for workable png version information""... $ac_c" 1>&6 -echo "configure:6938: checking for workable png version information" >&5 +echo "configure:6937: checking for workable png version information" >&5 xe_check_libs="-lpng -lz" cat > conftest.$ac_ext < int main(int c, char **v) { @@ -6945,7 +6944,7 @@ echo "configure:6938: checking for workable png version information" >&5 if (strcmp(png_libpng_ver, PNG_LIBPNG_VER_STRING) != 0) return 1; return (PNG_LIBPNG_VER < 10002) ? 2 : 0 ;} EOF -if { (eval echo configure:6949: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:6948: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ./conftest dummy_arg; png_status=$?; if test "$png_status" = "0"; then @@ -6988,15 +6987,15 @@ EOF test -z "$with_tiff" && { ac_safe=`echo "tiffio.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for tiffio.h""... $ac_c" 1>&6 -echo "configure:6992: checking for tiffio.h" >&5 +echo "configure:6991: checking for tiffio.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7000: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6999: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7019,12 +7018,12 @@ fi } test -z "$with_tiff" && { echo $ac_n "checking for TIFFClientOpen in -ltiff""... $ac_c" 1>&6 -echo "configure:7023: checking for TIFFClientOpen in -ltiff" >&5 +echo "configure:7022: checking for TIFFClientOpen in -ltiff" >&5 ac_lib_var=`echo tiff'_'TIFFClientOpen | sed 'y%./+-%__p_%'` xe_check_libs=" -ltiff " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7038: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7074,19 +7073,19 @@ fi if test "$with_x11" = "yes"; then echo "checking for X11 graphics libraries" 1>&6 -echo "configure:7078: checking for X11 graphics libraries" >&5 +echo "configure:7077: checking for X11 graphics libraries" >&5 test -z "$with_xface" && { ac_safe=`echo "compface.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for compface.h""... $ac_c" 1>&6 -echo "configure:7082: checking for compface.h" >&5 +echo "configure:7081: checking for compface.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7090: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7109,12 +7108,12 @@ fi } test -z "$with_xface" && { echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6 -echo "configure:7113: checking for UnGenFace in -lcompface" >&5 +echo "configure:7112: checking for UnGenFace in -lcompface" >&5 ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'` xe_check_libs=" -lcompface " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7128: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7161,12 +7160,12 @@ EOF echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6 -echo "configure:7165: checking for XawScrollbarSetThumb in -lXaw" >&5 +echo "configure:7164: checking for XawScrollbarSetThumb in -lXaw" >&5 ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'` xe_check_libs=" -lXaw " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7180: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7201,15 +7200,15 @@ fi ac_safe=`echo "Xm/Xm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for Xm/Xm.h""... $ac_c" 1>&6 -echo "configure:7205: checking for Xm/Xm.h" >&5 +echo "configure:7204: checking for Xm/Xm.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7213: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7212: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7226,12 +7225,12 @@ if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6 -echo "configure:7230: checking for XmStringFree in -lXm" >&5 +echo "configure:7229: checking for XmStringFree in -lXm" >&5 ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7245: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7271,9 +7270,9 @@ fi if test "$have_motif" = "yes"; then echo $ac_n "checking for Lesstif""... $ac_c" 1>&6 -echo "configure:7275: checking for Lesstif" >&5 +echo "configure:7274: checking for Lesstif" >&5 cat > conftest.$ac_ext < #ifdef LESSTIF_VERSION @@ -7557,7 +7556,7 @@ fi if test "$with_mule" = "yes" ; then echo "checking for Mule-related features" 1>&6 -echo "configure:7561: checking for Mule-related features" >&5 +echo "configure:7560: checking for Mule-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining MULE EOF @@ -7582,15 +7581,15 @@ EOF do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:7586: checking for $ac_hdr" >&5 +echo "configure:7585: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7594: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7593: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7621,12 +7620,12 @@ done echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6 -echo "configure:7625: checking for strerror in -lintl" >&5 +echo "configure:7624: checking for strerror in -lintl" >&5 ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'` xe_check_libs=" -lintl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7640: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7670,19 +7669,19 @@ fi echo "checking for Mule input methods" 1>&6 -echo "configure:7674: checking for Mule input methods" >&5 +echo "configure:7673: checking for Mule input methods" >&5 case "$with_xim" in "" | "yes" ) echo "checking for XIM" 1>&6 -echo "configure:7677: checking for XIM" >&5 +echo "configure:7676: checking for XIM" >&5 if test "$have_lesstif" = "yes"; then with_xim=xlib else echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6 -echo "configure:7681: checking for XmImMbLookupString in -lXm" >&5 +echo "configure:7680: checking for XmImMbLookupString in -lXm" >&5 ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7696: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7759,15 +7758,15 @@ EOF if test "$with_xfs" = "yes" ; then echo "checking for XFontSet" 1>&6 -echo "configure:7763: checking for XFontSet" >&5 +echo "configure:7762: checking for XFontSet" >&5 echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6 -echo "configure:7766: checking for XmbDrawString in -lX11" >&5 +echo "configure:7765: checking for XmbDrawString in -lX11" >&5 ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7781: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7818,15 +7817,15 @@ EOF test "$with_wnn6" = "yes" && with_wnn=yes # wnn6 implies wnn support test -z "$with_wnn" && { ac_safe=`echo "wnn/jllib.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for wnn/jllib.h""... $ac_c" 1>&6 -echo "configure:7822: checking for wnn/jllib.h" >&5 +echo "configure:7821: checking for wnn/jllib.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7830: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7829: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7851,10 +7850,10 @@ fi for ac_func in crypt do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:7855: checking for $ac_func" >&5 +echo "configure:7854: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7880: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7906,12 +7905,12 @@ done test "$ac_cv_func_crypt" != "yes" && { echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6 -echo "configure:7910: checking for crypt in -lcrypt" >&5 +echo "configure:7909: checking for crypt in -lcrypt" >&5 ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'` xe_check_libs=" -lcrypt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7957,12 +7956,12 @@ fi if test -z "$with_wnn" -o "$with_wnn" = "yes"; then echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6 -echo "configure:7961: checking for jl_dic_list_e in -lwnn" >&5 +echo "configure:7960: checking for jl_dic_list_e in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7976: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7991,12 +7990,12 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then else echo "$ac_t""no" 1>&6 echo $ac_n "checking for jl_dic_list_e in -lwnn4""... $ac_c" 1>&6 -echo "configure:7995: checking for jl_dic_list_e in -lwnn4" >&5 +echo "configure:7994: checking for jl_dic_list_e in -lwnn4" >&5 ac_lib_var=`echo wnn4'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn4 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8010: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8025,12 +8024,12 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then else echo "$ac_t""no" 1>&6 echo $ac_n "checking for jl_dic_list_e in -lwnn6""... $ac_c" 1>&6 -echo "configure:8029: checking for jl_dic_list_e in -lwnn6" >&5 +echo "configure:8028: checking for jl_dic_list_e in -lwnn6" >&5 ac_lib_var=`echo wnn6'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn6 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8044: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8059,12 +8058,12 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then else echo "$ac_t""no" 1>&6 echo $ac_n "checking for dic_list_e in -lwnn6_fromsrc""... $ac_c" 1>&6 -echo "configure:8063: checking for dic_list_e in -lwnn6_fromsrc" >&5 +echo "configure:8062: checking for dic_list_e in -lwnn6_fromsrc" >&5 ac_lib_var=`echo wnn6_fromsrc'_'dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn6_fromsrc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8078: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8123,12 +8122,12 @@ EOF if test "$with_wnn6" != "no"; then echo $ac_n "checking for jl_fi_dic_list in -l$libwnn""... $ac_c" 1>&6 -echo "configure:8127: checking for jl_fi_dic_list in -l$libwnn" >&5 +echo "configure:8126: checking for jl_fi_dic_list in -l$libwnn" >&5 ac_lib_var=`echo $libwnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'` xe_check_libs=" -l$libwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8142: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8174,15 +8173,15 @@ EOF if test "$with_canna" != "no"; then ac_safe=`echo "canna/jrkanji.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for canna/jrkanji.h""... $ac_c" 1>&6 -echo "configure:8178: checking for canna/jrkanji.h" >&5 +echo "configure:8177: checking for canna/jrkanji.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8186: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8185: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8209,15 +8208,15 @@ fi c_switch_site="$c_switch_site -I/usr/local/canna/include" ac_safe=`echo "canna/jrkanji.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for canna/jrkanji.h""... $ac_c" 1>&6 -echo "configure:8213: checking for canna/jrkanji.h" >&5 +echo "configure:8212: checking for canna/jrkanji.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8221: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8220: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8245,15 +8244,15 @@ fi test -z "$with_canna" && { ac_safe=`echo "canna/RK.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for canna/RK.h""... $ac_c" 1>&6 -echo "configure:8249: checking for canna/RK.h" >&5 +echo "configure:8248: checking for canna/RK.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8257: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8256: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8276,12 +8275,12 @@ fi } test -z "$with_canna" && { echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6 -echo "configure:8280: checking for RkBgnBun in -lRKC" >&5 +echo "configure:8279: checking for RkBgnBun in -lRKC" >&5 ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'` xe_check_libs=" -lRKC " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8295: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8315,12 +8314,12 @@ fi } test -z "$with_canna" && { echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6 -echo "configure:8319: checking for jrKanjiControl in -lcanna" >&5 +echo "configure:8318: checking for jrKanjiControl in -lcanna" >&5 ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'` xe_check_libs=" -lcanna " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8334: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8380,12 +8379,12 @@ if test "$need_motif" = "yes" ; then libs_x="-lXm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXm\" to \$libs_x"; fi echo $ac_n "checking for layout_object_getvalue in -li18n""... $ac_c" 1>&6 -echo "configure:8384: checking for layout_object_getvalue in -li18n" >&5 +echo "configure:8383: checking for layout_object_getvalue in -li18n" >&5 ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'` xe_check_libs=" -li18n " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8399: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8465,8 +8464,8 @@ if test "$GCC" = "yes"; then set x $ld_switch_run; shift; ld_switch_run="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;; + -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;; -Xlinker* ) ;; * ) ld_switch_run="$ld_switch_run -Xlinker $1" ;; esac @@ -8482,10 +8481,10 @@ fi for ac_func in cbrt closedir dup2 eaccess fmod fpathconf frexp ftime gethostname getpagesize gettimeofday getcwd getwd logb lrand48 matherr mkdir mktime perror poll random rename res_init rint rmdir select setitimer setpgid setlocale setsid sigblock sighold sigprocmask snprintf strcasecmp strerror tzset ulimit usleep utimes waitpid vsnprintf do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8486: checking for $ac_func" >&5 +echo "configure:8485: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8511: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8549,10 +8548,10 @@ case "$opsys" in * ) for ac_func in realpath do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8553: checking for $ac_func" >&5 +echo "configure:8552: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8578: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8609,16 +8608,16 @@ done esac echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6 -echo "configure:8613: checking whether netdb declares h_errno" >&5 +echo "configure:8612: checking whether netdb declares h_errno" >&5 cat > conftest.$ac_ext < int main() { return h_errno; ; return 0; } EOF -if { (eval echo configure:8622: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8621: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -8638,16 +8637,16 @@ fi rm -f conftest* echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6 -echo "configure:8642: checking for sigsetjmp" >&5 +echo "configure:8641: checking for sigsetjmp" >&5 cat > conftest.$ac_ext < int main() { sigjmp_buf bar; sigsetjmp (bar, 0); ; return 0; } EOF -if { (eval echo configure:8651: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:8650: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -8667,11 +8666,11 @@ fi rm -f conftest* echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6 -echo "configure:8671: checking whether localtime caches TZ" >&5 +echo "configure:8670: checking whether localtime caches TZ" >&5 if test "$ac_cv_func_tzset" = "yes"; then cat > conftest.$ac_ext < #if STDC_HEADERS @@ -8706,7 +8705,7 @@ main() exit (0); } EOF -if { (eval echo configure:8710: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:8709: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then emacs_cv_localtime_cache=no else @@ -8736,9 +8735,9 @@ fi if test "$HAVE_TIMEVAL" = "yes"; then echo $ac_n "checking whether gettimeofday accepts one or two arguments""... $ac_c" 1>&6 -echo "configure:8740: checking whether gettimeofday accepts one or two arguments" >&5 +echo "configure:8739: checking whether gettimeofday accepts one or two arguments" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""two" 1>&6 else @@ -8782,19 +8781,19 @@ fi echo $ac_n "checking for inline""... $ac_c" 1>&6 -echo "configure:8786: checking for inline" >&5 +echo "configure:8785: checking for inline" >&5 ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:8797: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_inline=$ac_kw; break else @@ -8844,17 +8843,17 @@ fi # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works # for constant arguments. Useless! echo $ac_n "checking for working alloca.h""... $ac_c" 1>&6 -echo "configure:8848: checking for working alloca.h" >&5 +echo "configure:8847: checking for working alloca.h" >&5 cat > conftest.$ac_ext < int main() { char *p = alloca(2 * sizeof(int)); ; return 0; } EOF -if { (eval echo configure:8858: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8857: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_header_alloca_h=yes else @@ -8878,10 +8877,10 @@ EOF fi echo $ac_n "checking for alloca""... $ac_c" 1>&6 -echo "configure:8882: checking for alloca" >&5 +echo "configure:8881: checking for alloca" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8907: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_func_alloca_works=yes else @@ -8943,10 +8942,10 @@ EOF echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6 -echo "configure:8947: checking whether alloca needs Cray hooks" >&5 +echo "configure:8946: checking whether alloca needs Cray hooks" >&5 cat > conftest.$ac_ext <&6 if test $ac_cv_os_cray = yes; then for ac_func in _getb67 GETB67 getb67; do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:8974: checking for $ac_func" >&5 +echo "configure:8973: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -9026,10 +9025,10 @@ done fi echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6 -echo "configure:9030: checking stack direction for C alloca" >&5 +echo "configure:9029: checking stack direction for C alloca" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9051: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_c_stack_direction=1 else @@ -9077,15 +9076,15 @@ test -n "$ALLOCA" && extra_objs="$extra_objs $ALLOCA" && if test "$extra_verbos ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for vfork.h""... $ac_c" 1>&6 -echo "configure:9081: checking for vfork.h" >&5 +echo "configure:9080: checking for vfork.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9088: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9113,10 +9112,10 @@ else fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:9117: checking for working vfork" >&5 +echo "configure:9116: checking for working vfork" >&5 cat > conftest.$ac_ext < @@ -9211,7 +9210,7 @@ main() { } } EOF -if { (eval echo configure:9215: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9214: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_vfork_works=yes else @@ -9237,10 +9236,10 @@ fi echo $ac_n "checking for working strcoll""... $ac_c" 1>&6 -echo "configure:9241: checking for working strcoll" >&5 +echo "configure:9240: checking for working strcoll" >&5 cat > conftest.$ac_ext < main () @@ -9250,7 +9249,7 @@ main () strcoll ("123", "456") >= 0); } EOF -if { (eval echo configure:9254: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9253: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_strcoll_works=yes else @@ -9278,10 +9277,10 @@ fi for ac_func in getpgrp do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:9282: checking for $ac_func" >&5 +echo "configure:9281: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9307: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -9332,10 +9331,10 @@ fi done echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6 -echo "configure:9336: checking whether getpgrp takes no argument" >&5 +echo "configure:9335: checking whether getpgrp takes no argument" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9393: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_getpgrp_void=yes else @@ -9417,10 +9416,10 @@ fi echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:9421: checking for working mmap" >&5 +echo "configure:9420: checking for working mmap" >&5 case "$opsys" in ultrix* ) have_mmap=no ;; *) cat > conftest.$ac_ext < #include @@ -9453,7 +9452,7 @@ int main (int argc, char *argv[]) return 1; } EOF -if { (eval echo configure:9457: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9456: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then have_mmap=yes else @@ -9478,15 +9477,15 @@ for ac_hdr in unistd.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:9482: checking for $ac_hdr" >&5 +echo "configure:9481: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9490: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9518,10 +9517,10 @@ done for ac_func in getpagesize do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:9522: checking for $ac_func" >&5 +echo "configure:9521: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9547: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -9572,10 +9571,10 @@ fi done echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:9576: checking for working mmap" >&5 +echo "configure:9575: checking for working mmap" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9718: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_mmap_fixed_mapped=yes else @@ -9753,15 +9752,15 @@ EOF ac_safe=`echo "termios.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termios.h""... $ac_c" 1>&6 -echo "configure:9757: checking for termios.h" >&5 +echo "configure:9756: checking for termios.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9765: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9764: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9804,15 +9803,15 @@ else echo "$ac_t""no" 1>&6 ac_safe=`echo "termio.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for termio.h""... $ac_c" 1>&6 -echo "configure:9808: checking for termio.h" >&5 +echo "configure:9807: checking for termio.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9816: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9815: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9844,10 +9843,10 @@ fi echo $ac_n "checking for socket""... $ac_c" 1>&6 -echo "configure:9848: checking for socket" >&5 +echo "configure:9847: checking for socket" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9873: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_socket=yes" else @@ -9885,15 +9884,15 @@ if eval "test \"`echo '$ac_cv_func_'socket`\" = yes"; then echo "$ac_t""yes" 1>&6 ac_safe=`echo "netinet/in.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for netinet/in.h""... $ac_c" 1>&6 -echo "configure:9889: checking for netinet/in.h" >&5 +echo "configure:9888: checking for netinet/in.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9897: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9896: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9910,15 +9909,15 @@ if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 ac_safe=`echo "arpa/inet.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for arpa/inet.h""... $ac_c" 1>&6 -echo "configure:9914: checking for arpa/inet.h" >&5 +echo "configure:9913: checking for arpa/inet.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9922: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9921: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9943,9 +9942,9 @@ EOF } echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6 -echo "configure:9947: checking "for sun_len member in struct sockaddr_un"" >&5 +echo "configure:9946: checking "for sun_len member in struct sockaddr_un"" >&5 cat > conftest.$ac_ext < @@ -9956,7 +9955,7 @@ int main() { static struct sockaddr_un x; x.sun_len = 1; ; return 0; } EOF -if { (eval echo configure:9960: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9959: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SOCKADDR_SUN_LEN @@ -9974,9 +9973,9 @@ else fi rm -f conftest* echo $ac_n "checking "for ip_mreq struct in netinet/in.h"""... $ac_c" 1>&6 -echo "configure:9978: checking "for ip_mreq struct in netinet/in.h"" >&5 +echo "configure:9977: checking "for ip_mreq struct in netinet/in.h"" >&5 cat > conftest.$ac_ext < @@ -9986,7 +9985,7 @@ int main() { static struct ip_mreq x; ; return 0; } EOF -if { (eval echo configure:9990: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9989: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_MULTICAST @@ -10017,10 +10016,10 @@ fi echo $ac_n "checking for msgget""... $ac_c" 1>&6 -echo "configure:10021: checking for msgget" >&5 +echo "configure:10020: checking for msgget" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10046: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_msgget=yes" else @@ -10058,15 +10057,15 @@ if eval "test \"`echo '$ac_cv_func_'msgget`\" = yes"; then echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/ipc.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/ipc.h""... $ac_c" 1>&6 -echo "configure:10062: checking for sys/ipc.h" >&5 +echo "configure:10061: checking for sys/ipc.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10070: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10069: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10083,15 +10082,15 @@ if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 ac_safe=`echo "sys/msg.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/msg.h""... $ac_c" 1>&6 -echo "configure:10087: checking for sys/msg.h" >&5 +echo "configure:10086: checking for sys/msg.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10095: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10094: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10129,15 +10128,15 @@ fi ac_safe=`echo "dirent.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for dirent.h""... $ac_c" 1>&6 -echo "configure:10133: checking for dirent.h" >&5 +echo "configure:10132: checking for dirent.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10141: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10140: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10164,15 +10163,15 @@ else echo "$ac_t""no" 1>&6 ac_safe=`echo "sys/dir.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for sys/dir.h""... $ac_c" 1>&6 -echo "configure:10168: checking for sys/dir.h" >&5 +echo "configure:10167: checking for sys/dir.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10176: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10175: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10205,15 +10204,15 @@ fi ac_safe=`echo "nlist.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for nlist.h""... $ac_c" 1>&6 -echo "configure:10209: checking for nlist.h" >&5 +echo "configure:10208: checking for nlist.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10217: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10216: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10243,7 +10242,7 @@ fi echo "checking "for sound support"" 1>&6 -echo "configure:10247: checking "for sound support"" >&5 +echo "configure:10246: checking "for sound support"" >&5 case "$with_sound" in native | both ) with_native_sound=yes;; nas | no ) with_native_sound=no;; @@ -10254,15 +10253,15 @@ if test "$with_native_sound" != "no"; then if test -n "$native_sound_lib"; then ac_safe=`echo "multimedia/audio_device.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for multimedia/audio_device.h""... $ac_c" 1>&6 -echo "configure:10258: checking for multimedia/audio_device.h" >&5 +echo "configure:10257: checking for multimedia/audio_device.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10266: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10265: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10310,12 +10309,12 @@ fi if test -z "$native_sound_lib"; then echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6 -echo "configure:10314: checking for ALopenport in -laudio" >&5 +echo "configure:10313: checking for ALopenport in -laudio" >&5 ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'` xe_check_libs=" -laudio " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10329: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10357,12 +10356,12 @@ fi if test -z "$native_sound_lib"; then echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6 -echo "configure:10361: checking for AOpenAudio in -lAlib" >&5 +echo "configure:10360: checking for AOpenAudio in -lAlib" >&5 ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'` xe_check_libs=" -lAlib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10376: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10411,15 +10410,15 @@ fi for dir in "machine" "sys" "linux"; do ac_safe=`echo "${dir}/soundcard.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ${dir}/soundcard.h""... $ac_c" 1>&6 -echo "configure:10415: checking for ${dir}/soundcard.h" >&5 +echo "configure:10414: checking for ${dir}/soundcard.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10423: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10422: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10489,7 +10488,7 @@ EOF fi libs_x="-laudio $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-laudio\" to \$libs_x"; fi cat > conftest.$ac_ext < EOF @@ -10516,7 +10515,7 @@ test -z "$with_tty" && with_tty=yes if test "$with_tty" = "yes" ; then echo "checking for TTY-related features" 1>&6 -echo "configure:10520: checking for TTY-related features" >&5 +echo "configure:10519: checking for TTY-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_TTY EOF @@ -10532,12 +10531,12 @@ EOF if test -z "$with_ncurses"; then echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6 -echo "configure:10536: checking for tgetent in -lncurses" >&5 +echo "configure:10535: checking for tgetent in -lncurses" >&5 ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lncurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10551: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10581,15 +10580,15 @@ EOF ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:10585: checking for ncurses/curses.h" >&5 +echo "configure:10584: checking for ncurses/curses.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10593: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10592: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10611,15 +10610,15 @@ fi ac_safe=`echo "ncurses/term.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/term.h""... $ac_c" 1>&6 -echo "configure:10615: checking for ncurses/term.h" >&5 +echo "configure:10614: checking for ncurses/term.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10623: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10622: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10649,15 +10648,15 @@ fi c_switch_site="$c_switch_site -I/usr/include/ncurses" ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6 -echo "configure:10653: checking for ncurses/curses.h" >&5 +echo "configure:10652: checking for ncurses/curses.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10661: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10660: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10692,12 +10691,12 @@ fi for lib in curses termlib termcap; do echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6 -echo "configure:10696: checking for tgetent in -l$lib" >&5 +echo "configure:10695: checking for tgetent in -l$lib" >&5 ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -l$lib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10739,12 +10738,12 @@ fi else echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6 -echo "configure:10743: checking for tgetent in -lcurses" >&5 +echo "configure:10742: checking for tgetent in -lcurses" >&5 ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lcurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10773,12 +10772,12 @@ if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes" ; then else echo "$ac_t""no" 1>&6 echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6 -echo "configure:10777: checking for tgetent in -ltermcap" >&5 +echo "configure:10776: checking for tgetent in -ltermcap" >&5 ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -ltermcap " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10792: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10837,15 +10836,15 @@ EOF test -z "$with_gpm" && { ac_safe=`echo "gpm.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for gpm.h""... $ac_c" 1>&6 -echo "configure:10841: checking for gpm.h" >&5 +echo "configure:10840: checking for gpm.h" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10849: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10848: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10868,12 +10867,12 @@ fi } test -z "$with_gpm" && { echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6 -echo "configure:10872: checking for Gpm_Open in -lgpm" >&5 +echo "configure:10871: checking for Gpm_Open in -lgpm" >&5 ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgpm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10887: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10933,22 +10932,22 @@ test "$with_x11" = "yes" -o "$with_tty" = "yes" && extra_objs="$extra_objs event echo "checking for database support" 1>&6 -echo "configure:10937: checking for database support" >&5 +echo "configure:10936: checking for database support" >&5 if test "$with_database_gnudbm" != "no"; then for ac_hdr in ndbm.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:10944: checking for $ac_hdr" >&5 +echo "configure:10943: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10952: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10951: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10980,12 +10979,12 @@ done if test "$have_ndbm_h" = "yes"; then echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6 -echo "configure:10984: checking for dbm_open in -lgdbm" >&5 +echo "configure:10983: checking for dbm_open in -lgdbm" >&5 ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11019,10 +11018,10 @@ fi fi if test "$with_database_gnudbm" != "yes"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:11023: checking for dbm_open" >&5 +echo "configure:11022: checking for dbm_open" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11048: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -11081,10 +11080,10 @@ fi if test "$with_database_dbm" != "no"; then echo $ac_n "checking for dbm_open""... $ac_c" 1>&6 -echo "configure:11085: checking for dbm_open" >&5 +echo "configure:11084: checking for dbm_open" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11110: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -11128,12 +11127,12 @@ fi if test "$need_libdbm" != "no"; then echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6 -echo "configure:11132: checking for dbm_open in -ldbm" >&5 +echo "configure:11131: checking for dbm_open in -ldbm" >&5 ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -ldbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11147: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11181,10 +11180,10 @@ fi if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for Berkeley db.h""... $ac_c" 1>&6 -echo "configure:11185: checking for Berkeley db.h" >&5 +echo "configure:11184: checking for Berkeley db.h" >&5 for path in "db/db.h" "db.h"; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:11205: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* db_h_path="$path"; break else @@ -11218,9 +11217,9 @@ rm -f conftest* if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for Berkeley DB version""... $ac_c" 1>&6 -echo "configure:11222: checking for Berkeley DB version" >&5 +echo "configure:11221: checking for Berkeley DB version" >&5 cat > conftest.$ac_ext < #if DB_VERSION_MAJOR > 1 @@ -11239,10 +11238,10 @@ fi rm -f conftest* echo $ac_n "checking for $dbfunc""... $ac_c" 1>&6 -echo "configure:11243: checking for $dbfunc" >&5 +echo "configure:11242: checking for $dbfunc" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$dbfunc=yes" else @@ -11284,12 +11283,12 @@ else echo $ac_n "checking for $dbfunc in -ldb""... $ac_c" 1>&6 -echo "configure:11288: checking for $dbfunc in -ldb" >&5 +echo "configure:11287: checking for $dbfunc in -ldb" >&5 ac_lib_var=`echo db'_'$dbfunc | sed 'y%./+-%__p_%'` xe_check_libs=" -ldb " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11303: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11364,12 +11363,12 @@ fi if test "$with_socks" = "yes"; then echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6 -echo "configure:11368: checking for SOCKSinit in -lsocks" >&5 +echo "configure:11367: checking for SOCKSinit in -lsocks" >&5 ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocks " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11383: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11439,15 +11438,15 @@ for ac_hdr in dlfcn.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:11443: checking for $ac_hdr" >&5 +echo "configure:11442: checking for $ac_hdr" >&5 cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:11451: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:11450: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -11478,12 +11477,12 @@ done test -z "$with_shlib" && test ! -z "$have_dlfcn" && { echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 -echo "configure:11482: checking for dlopen in -ldl" >&5 +echo "configure:11481: checking for dlopen in -ldl" >&5 ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` xe_check_libs=" -ldl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11497: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11523,12 +11522,12 @@ fi } test -z "$with_shlib" && test ! -z "$have_dlfcn" && { echo $ac_n "checking for _dlopen in -lc""... $ac_c" 1>&6 -echo "configure:11527: checking for _dlopen in -lc" >&5 +echo "configure:11526: checking for _dlopen in -lc" >&5 ac_lib_var=`echo c'_'_dlopen | sed 'y%./+-%__p_%'` xe_check_libs=" -lc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11542: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11568,12 +11567,12 @@ fi } test -z "$with_shlib" && test ! -z "$have_dlfcn" && { echo $ac_n "checking for dlopen in -lc""... $ac_c" 1>&6 -echo "configure:11572: checking for dlopen in -lc" >&5 +echo "configure:11571: checking for dlopen in -lc" >&5 ac_lib_var=`echo c'_'dlopen | sed 'y%./+-%__p_%'` xe_check_libs=" -lc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11587: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11613,12 +11612,12 @@ fi } test -z "$with_shlib" && { echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6 -echo "configure:11617: checking for shl_load in -ldld" >&5 +echo "configure:11616: checking for shl_load in -ldld" >&5 ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'` xe_check_libs=" -ldld " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11632: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11658,12 +11657,12 @@ fi } test -z "$with_shlib" && { echo $ac_n "checking for dld_init in -ldld""... $ac_c" 1>&6 -echo "configure:11662: checking for dld_init in -ldld" >&5 +echo "configure:11661: checking for dld_init in -ldld" >&5 ac_lib_var=`echo dld'_'dld_init | sed 'y%./+-%__p_%'` xe_check_libs=" -ldld " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11677: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11724,7 +11723,7 @@ dll_cflags="-r" dll_oflags="-o " echo $ac_n "checking how to build a shared library""... $ac_c" 1>&6 -echo "configure:11728: checking how to build a shared library" >&5 +echo "configure:11727: checking how to build a shared library" >&5 case `uname -rs` in UNIX_SV*|UNIX_System_V*) dll_lflags="-G" @@ -11815,10 +11814,10 @@ case `uname -rs` in for ac_func in dlerror do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:11819: checking for $ac_func" >&5 +echo "configure:11818: checking for $ac_func" >&5 cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11844: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -11877,11 +11876,11 @@ done fi cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:11884: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then : else @@ -11980,7 +11979,7 @@ ld_libs_all="$T" MAKE_SUBDIR="$MAKE_SUBDIR src" && if test "$extra_verbose" = "yes"; then echo " Appending \"src\" to \$MAKE_SUBDIR"; fi -internal_makefile_list="Makefile" +internal_makefile_list="Makefile.in" SUBDIR_MAKEFILES='' test -d lock || mkdir lock for dir in $MAKE_SUBDIR; do @@ -12171,7 +12170,10 @@ RECURSIVE_MAKE="\$(MAKE) \$(MFLAGS) CC='\$(CC)' CFLAGS='\$(CFLAGS)' LDFLAGS='\$( -# The default is yes +: ${XEMACS_CC:=$CC} + + + if test "$with_site_lisp" = "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining INHIBIT_SITE_LISP @@ -12331,19 +12333,19 @@ cat >> confdefs.h <<\EOF EOF } -test "$with_gnu_make" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF - Defining USE_GNU_MAKE +test "$no_doc_file" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF + Defining NO_DOC_FILE EOF cat >> confdefs.h <<\EOF -#define USE_GNU_MAKE 1 +#define NO_DOC_FILE 1 EOF } -test "$no_doc_file" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF - Defining NO_DOC_FILE +test "$with_purify" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF + Defining PURIFY EOF cat >> confdefs.h <<\EOF -#define NO_DOC_FILE 1 +#define PURIFY 1 EOF } @@ -12472,7 +12474,7 @@ case "$with_sound" in native ) echo " Compiling in native sound support." ;; both ) echo " Compiling in both network and native sound support." ;; esac -test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously" +test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously." test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB." test "$with_database_dbm" = yes && echo " Compiling in support for DBM." @@ -12526,9 +12528,9 @@ test "$with_shlib" = "yes" && echo " Compiling in DLL support." test "$with_clash_detection" = yes && \ echo " Clash detection will use \"$lockdir\" for locking files." echo " movemail will use \"$mail_locking\" for locking mail spool files." -test "$with_pop" = yes && echo " Using POP for mail access" -test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" -test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" +test "$with_pop" = yes && echo " Using POP for mail access." +test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication." +test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host." test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$use_minimal_tagbits" = yes && echo " Using Lisp_Objects with minimal tagbits." test "$use_indexed_lrecord_implementation" = yes && echo " Using indexed lrecord implementation." @@ -12552,7 +12554,6 @@ sed 's/"/\\"/g' Installation >> Installation.el echo '")' >> Installation.el - # Remove any trailing slashes in these variables. test -n "$prefix" && prefix=`echo '' "$prefix" | sed -e 's:^ ::' -e 's,\([^/]\)/*$,\1,'` @@ -12731,6 +12732,7 @@ s%@RECURSIVE_MAKE@%$RECURSIVE_MAKE%g s%@native_sound_lib@%$native_sound_lib%g s%@sound_cflags@%$sound_cflags%g s%@dynodump_arch@%$dynodump_arch%g +s%@XEMACS_CC@%$XEMACS_CC%g s%@internal_makefile_list@%$internal_makefile_list%g CEOF @@ -12942,14 +12944,12 @@ fi; done EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF -for dir in $MAKE_SUBDIR; do - echo creating $dir/Makefile +for dir in . $MAKE_SUBDIR; do ( cd $dir rm -f junk.c @@ -12961,26 +12961,45 @@ for dir in $MAKE_SUBDIR; do -e '/^#/ { p d -}' -e '/./ { +}' \ + -e '/./ { s/\([\"]\)/\\\1/g s/^/"/ s/$/"/ }' > junk.c; - $CPP -I. -I${top_srcdir}/src $CPPFLAGS junk.c > junk.cpp; - < junk.cpp \ - sed -e 's/^#.*//' \ - -e 's/^[ ][ ]*$//' \ - -e 's/^ / /' \ - | sed -n -e '/^..*$/p' \ - | sed '/^"/ { -s/\\\([\"]\)/\1/g -s/^[ ]*"// -s/"[ ]*$// -}' > Makefile.new + + + + echo creating $dir/Makefile +$CPP -I. -I${top_srcdir}/src junk.c \ + | sed -e 's/^\#.*//' \ + -e 's/^[ ][ ]*$//'\ + -e 's/^ / /' \ + | sed -n -e '/^..*$/p' \ + | sed '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ ]*\"// + s/\"[ ]*$// +}' > Makefile.new chmod 444 Makefile.new mv -f Makefile.new Makefile - rm -f junk.c junk.cpp -) + + echo creating $dir/GNUmakefile +$CPP -I. -I${top_srcdir}/src -DUSE_GNU_MAKE junk.c \ + | sed -e 's/^\#.*//' \ + -e 's/^[ ][ ]*$//'\ + -e 's/^ / /' \ + | sed -n -e '/^..*$/p' \ + | sed '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ ]*\"// + s/\"[ ]*$// +}' > Makefile.new + chmod 444 Makefile.new + mv -f Makefile.new GNUmakefile + + rm -f junk.c + ) done sed < config.status >> lib-src/config.values \ @@ -12995,4 +13014,3 @@ EOF chmod +x $CONFIG_STATUS rm -fr confdefs* $ac_clean_files test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - diff --git a/configure.in b/configure.in index 349072b..9b815df 100644 --- a/configure.in +++ b/configure.in @@ -229,6 +229,13 @@ define([XE_PREPEND], [[$2]="[$1] $[$2]" && dnl if test "$extra_verbose" = "yes"; then echo " Prepending \"[$1]\" to \$[$2]"; fi]) +dnl XE_DIE(message) +define([XE_DIE], [{ echo $1 >&2; exit 1; }]) + +dnl XE_STRIP_4TH_COMPONENT(var) +dnl Changes i986-pc-linux-gnu to i986-pc-linux, as God (not RMS) intended. +define([XE_STRIP_4TH_COMPONENT], +[$1=`echo "$$1" | sed '[s/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/]'`]) dnl Initialize some variables set by options. dnl The variables have the same names as the options, with @@ -326,7 +333,6 @@ dnl ----------------------------- XE_APPEND(lib-src, MAKE_SUBDIR) XE_APPEND(lib-src, INSTALL_ARCH_DEP_SUBDIR) -dnl run_in_place='no' prefix='/usr/local' exec_prefix='${prefix}' bindir='${exec_prefix}/bin' @@ -453,13 +459,11 @@ while test $# != 0; do case "$opt" in dnl Process (many) boolean options - run_in_place | \ - with_site_lisp | \ + with_site_lisp | \ with_x | \ with_x11 | \ with_msw | \ with_gcc | \ - with_gnu_make | \ dynamic | \ with_ncurses | \ with_dnet | \ @@ -476,19 +480,20 @@ while test $# != 0; do with_tiff | \ with_session | \ with_xmu | \ + with_purify | \ with_quantify | \ with_toolbars | \ with_tty | \ with_xfs | \ with_i18n3 | \ with_mule | \ - with_file_coding | \ + with_file_coding| \ with_canna | \ with_wnn | \ with_wnn6 | \ with_workshop | \ with_sparcworks | \ - with_tooltalk | \ + with_tooltalk | \ with_ldap | \ with_pop | \ with_kerberos | \ @@ -499,14 +504,13 @@ while test $# != 0; do verbose | \ extra_verbose | \ const_is_losing | \ - usage_tracking | \ - use_union_type | \ + usage_tracking | \ + use_union_type | \ debug | \ use_assertions | \ + gung_ho | \ use_minimal_tagbits | \ use_indexed_lrecord_implementation | \ - gung_ho | \ - use_assertions | \ memory_usage_stats | \ with_clash_detection | \ with_shlib | \ @@ -514,10 +518,10 @@ while test $# != 0; do dnl Make sure the value given was either "yes" or "no". case "$val" in y | ye | yes ) val=yes ;; - n | no ) val=no ;; + n | no ) val=no ;; * ) USAGE_ERROR("The \`--$optname' option requires a boolean value: \`yes' or \`no'.") ;; esac - eval "$opt=\"$val\"" ;; + eval "$opt=\"$val\"" ;; dnl Options that take a user-supplied value, as in --puresize=8000000 @@ -531,7 +535,7 @@ while test $# != 0; do ldflags | \ puresize | \ cache_file | \ - native_sound_lib | \ + native_sound_lib| \ site_lisp | \ x_includes | \ x_libraries | \ @@ -579,7 +583,7 @@ while test $# != 0; do g | gn | gnu | gnud | gnudb | gnudbm ) with_database_gnudbm=yes ;; * ) USAGE_ERROR(["The \`--$optname' option value must be either \`no' or a comma-separated list - of one or more of \`berkdb', \`dbm', or \`gnudbm'."]) ;; + of one or more of \`berkdb' and either \`dbm' or \`gnudbm'."]) ;; esac done if test "$with_database_dbm" = "yes" -a \ @@ -618,17 +622,6 @@ while test $# != 0; do eval "$opt=\"$val\"" ;; - dnl XFontSet support? - "with_xfs" ) - case "$val" in - y | ye | yes ) val=yes ;; - n | no | non | none ) val=no ;; - * ) USAGE_ERROR(["The \`--$optname' option must have one of these values: - \`yes', or \`no'."]) ;; - esac - eval "$opt=\"$val\"" - ;; - dnl Mail locking specification "mail_locking" ) case "$val" in @@ -699,7 +692,7 @@ while test $# != 0; do dnl Has the user specified one of the path options? prefix | exec_prefix | bindir | datadir | statedir | libdir | \ mandir | infodir | infopath | lispdir | etcdir | lockdir | pkgdir | \ - archlibdir | docdir | package_path ) + archlibdir | docdir | package_path ) dnl If the value was omitted, get it from the next argument. if test "$valomitted" = "yes"; then if test "$#" = 0; then @@ -733,9 +726,10 @@ dnl sitelispdir ) AC_DEFINE(SITELISPDIR_USER_DEFINED) ;; dnl Has the user asked for some help? "usage" | "help" ) ${PAGER-more} ${srcdir}/configure.usage; exit 0 ;; - dnl Has the user specified what toolkit to use for the menubars, - dnl scrollbar or dialogs? - "with_menubars" | "with_scrollbars" | "with_dialogs" ) + dnl Has the user specified the toolkit(s) to use for GUI elements? + "with_menubars" | \ + "with_scrollbars" | \ + "with_dialogs" ) case "$val" in l | lu | luc | luci | lucid ) val=lucid ;; m | mo | mot | moti | motif ) val=motif ;; @@ -748,7 +742,13 @@ dnl sitelispdir ) AC_DEFINE(SITELISPDIR_USER_DEFINED) ;; eval "$opt=\"$val\"" ;; - dnl Fail on unrecognized arguments. + dnl Obsolete legacy argument? Warn, but otherwise ignore. + "run_in_place" | \ + "with_gnu_make" ) + AC_MSG_WARN([Obsolete option \`--$optname' ignored.]) + ;; + + dnl Unrecognized option? No mercy for user errors. * ) USAGE_ERROR("Unrecognized option: $arg") ;; esac @@ -757,7 +757,7 @@ dnl sitelispdir ) AC_DEFINE(SITELISPDIR_USER_DEFINED) ;; dnl Assume anything with multiple hyphens is a configuration name. *-*-*) configuration="$arg" ;; - dnl Anything else is an error + dnl Unrecognized argument? No mercy for user errors. *) USAGE_ERROR("Unrecognized argument: $arg") ;; esac @@ -779,20 +779,16 @@ eval set x "$quoted_arguments"; shift dnl --extra-verbose implies --verbose test "$extra_verbose" = "yes" && verbose=yes -dnl Allow use of either ":" or spaces for lists of directories -define(COLON_TO_SPACE, - [case "$[$1]" in *:* [)] [$1]="`echo '' $[$1] | sed -e 's/^ //' -e 's/:/ /g'`";; esac])dnl -COLON_TO_SPACE(site_includes) -COLON_TO_SPACE(site_libraries) -COLON_TO_SPACE(site_prefixes) -COLON_TO_SPACE(site_runtime_libraries) - dnl with_x is an obsolete synonym for with_x11 test -n "$with_x" && with_x11="$with_x" +dnl --with-quantify or --with-purify imply --use-system-malloc +if test "$with_purify" = "yes" -o "$with_quantify" = "yes"; then + test "$with_system_malloc" = "default" && with_system_malloc=yes +fi + dnl --gung-ho=val is a synonym for dnl --use-minimal-tagbits=val --use-indexed-lrecord-implementation=val - if test -n "$gung_ho"; then test -z "$use_minimal_tagbits" && use_minimal_tagbits="$gung_ho" test -z "$use_indexed_lrecord_implementation" && \ @@ -816,11 +812,6 @@ fi dnl CDE requires tooltalk XE_CHECK_FEATURE_DEPENDENCY(cde, tooltalk) -dnl Ignore useless run-in-place flag -if test "$run_in_place" = "yes"; then - AC_MSG_WARN("The --run-in-place option is ignored because it is unnecessary.") -fi - dnl Find the source directory. case "$srcdir" in @@ -856,13 +847,9 @@ esac dnl ########################################################################### if test -z "$configuration"; then - AC_MSG_CHECKING("host system type") - dnl Guess the configuration and remove 4th name component, if present. - if configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess | \ - sed '[s/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/]'` ; then - AC_MSG_RESULT($configuration) - else - AC_MSG_RESULT(unknown) + dnl Guess the configuration + configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess` + if test -z "$configuration"; then USAGE_ERROR(["XEmacs has not been ported to this host type. Try explicitly specifying the CONFIGURATION when rerunning configure."]) fi @@ -985,12 +972,13 @@ dnl Given the configuration name, set machfile and opsysfile to the dnl names of the m/*.h and s/*.h files we should use. dnl Canonicalize the configuration name. -AC_CHECKING("the configuration name") +AC_MSG_CHECKING("host system type") dnl allow -workshop suffix on configuration name internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'` -if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else - exit $? -fi +canonical=`${CONFIG_SHELL-/bin/sh} $srcdir/config.sub "$internal_configuration"` +XE_STRIP_4TH_COMPONENT(configuration) +XE_STRIP_4TH_COMPONENT(canonical) +AC_MSG_RESULT($configuration) dnl If you add support for a new configuration, add code to this dnl switch statement to recognize your configuration name and select @@ -1033,6 +1021,8 @@ case "$canonical" in m68*-sony-* ) machine=news ;; mips-sony-* ) machine=news-risc ;; clipper-* ) machine=clipper ;; + arm-* ) machine=arm ;; + ns32k-* ) machine=ns32000 ;; esac dnl Straightforward OS determination @@ -1103,13 +1093,9 @@ case "$canonical" in dnl OpenBSD ports *-*-openbsd* ) case "${canonical}" in - alpha*-*-openbsd*) machine=alpha ;; i386-*-openbsd*) machine=intel386 ;; m68k-*-openbsd*) machine=hp9000s300 ;; mipsel-*-openbsd*) machine=pmax ;; - ns32k-*-openbsd*) machine=ns32000 ;; - sparc-*-openbsd*) machine=sparc ;; - vax-*-openbsd*) machine=vax ;; esac ;; @@ -1489,9 +1475,6 @@ case "$canonical" in dnl Linux/68k m68k-*-linux* ) machine=m68k opsys=linux ;; - dnl Linux/arm - arm-*-linux* ) machine=arm opsys=linux ;; - esac if test -z "$machine" -o -z "$opsys"; then @@ -1728,7 +1711,7 @@ EOF dnl The value of CPP is a quoted variable reference, so we need to do this dnl to get its actual value... -CPP=`eval "echo $CPP"` +CPP=`eval "echo $CPP $CPPFLAGS"` define(TAB, [ ])dnl changequote(, )dnl eval `$CPP -Isrc $tempcname \ @@ -1787,8 +1770,8 @@ if test "$GCC" = "yes"; then set x $[$1]; shift; [$1]="" while test -n "[$]1"; do case [$]1 in - -L | -l | -u ) [$1]="$[$1] [$]1 [$]2"; shift ;; - -L* | -l* | -u* | -Wl* ) [$1]="$[$1] [$]1" ;; + -L | -l | -u ) [$1]="$[$1] [$]1 [$]2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) [$1]="$[$1] [$]1" ;; -Xlinker* ) ;; * ) [$1]="$[$1] -Xlinker [$]1" ;; esac @@ -1860,39 +1843,61 @@ dnl --------------------------------------------------------------- dnl Add site and system specific flags to compile and link commands dnl --------------------------------------------------------------- -dnl All dirs present in site-prefixes will be searched for include/ and lib/ -dnl subdirs. This can avoid specifying both site-includes and site-libraries. -dnl Those dirs will take precedence over the standard places, but not over -dnl site-includes and site-libraries. - -dnl --site-prefixes (multiple dirs) -if test -n "$site_prefixes"; then - for arg in $site_prefixes; do - case "$arg" in - -* ) ;; - * ) argi="-I${arg}/include" ; argl="-L${arg}/lib" ;; - esac - XE_APPEND($argi, c_switch_site) - XE_APPEND($argl, ld_switch_site) - done -fi +dnl Allow use of either ":" or spaces for lists of directories +define(COLON_TO_SPACE, + [case "$[$1]" in *:* [)] [$1]="`echo '' $[$1] | sed -e 's/^ //' -e 's/:/ /g'`";; esac])dnl dnl --site-libraries (multiple dirs) +COLON_TO_SPACE(site_libraries) if test -n "$site_libraries"; then for arg in $site_libraries; do - case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + XE_DIE("Invalid site library \`$arg': no such directory") + arg="-L${arg}" ;; + esac XE_APPEND($arg, ld_switch_site) done fi dnl --site-includes (multiple dirs) +COLON_TO_SPACE(site_includes) if test -n "$site_includes"; then for arg in $site_includes; do - case "$arg" in -* ) ;; * ) arg="-I${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + XE_DIE("Invalid site include \`$arg': no such directory") + arg="-I${arg}" ;; + esac XE_APPEND($arg, c_switch_site) done fi +dnl --site-prefixes (multiple dirs) +dnl --site-prefixes=dir1:dir2 is a convenient shorthand for +dnl --site-libraries=dir1/lib:dir2/lib --site-includes=dir1/include:dir2/include +dnl Site prefixes take precedence over the standard places, but not over +dnl site-includes and site-libraries. +COLON_TO_SPACE(site_prefixes) +if test -n "$site_prefixes"; then + for dir in $site_prefixes; do + inc_dir="${dir}/include" + lib_dir="${dir}/lib" + if test ! -d "$dir"; then + XE_DIE("Invalid site prefix \`$dir': no such directory") + elif test ! -d "$inc_dir"; then + XE_DIE("Invalid site prefix \`$dir': no such directory \`$inc_dir'") + elif test ! -d "$lib_dir"; then + XE_DIE("Invalid site prefix \`$dir': no such directory \`$lib_dir'") + else + XE_APPEND("-I$inc_dir", c_switch_site) + XE_APPEND("-L$lib_dir", ld_switch_site) + fi + done +fi + dnl GNU software installs by default into /usr/local/{include,lib} dnl if test -d "/usr/local/include" -a -d "/usr/local/lib"; then dnl XE_APPEND("-L/usr/local/lib", ld_switch_site) @@ -1905,6 +1910,7 @@ for dir in "/usr/ccs/lib"; do done dnl --site-runtime-libraries (multiple dirs) +COLON_TO_SPACE(site_runtime_libraries) if test -n "$site_runtime_libraries"; then LD_RUN_PATH="`echo $site_runtime_libraries | sed -e 's/ */:/g'`" export LD_RUN_PATH @@ -2092,7 +2098,7 @@ AC_PROG_YACC dnl checks for header files AC_CHECK_HEADERS(mach/mach.h sys/stropts.h sys/timeb.h sys/time.h unistd.h) AC_CHECK_HEADERS(utime.h locale.h libgen.h fcntl.h ulimit.h cygwin/version.h) -AC_CHECK_HEADERS(linux/version.h kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h) +AC_CHECK_HEADERS(kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h) AC_HEADER_SYS_WAIT AC_HEADER_STDC AC_HEADER_TIME @@ -2464,12 +2470,12 @@ if test "$with_msw" != "no"; then test "$with_dialogs" != "no" && with_dialogs=msw \ && XE_ADD_OBJS(dialog-msw.o) else - test "$with_scrollbars" != "no" && XE_ADD_OBJS(scrollbar-msw.o) + test "$with_scrollbars" != "no" && XE_ADD_OBJS(scrollbar-msw.o) test "$with_menubars" != "no" && XE_ADD_OBJS(menubar-msw.o) test "$with_toolbars" != "no" && XE_ADD_OBJS(toolbar-msw.o) - test "$with_dialogs" != "no" && XE_ADD_OBJS(dialog-msw.o) + test "$with_dialogs" != "no" && XE_ADD_OBJS(dialog-msw.o) fi - dnl check for our special version of select + dnl check for our special version of select AC_TRY_RUN([#include int main() { return (open("/dev/windows", O_RDONLY, 0) > 0)? 0 : 1; }], [AC_DEFINE(HAVE_MSG_SELECT)]) @@ -2617,7 +2623,7 @@ if test "$with_cde" = "yes" ; then fi dnl Always compile OffiX unless --without-offix is given, no -dnl X11 support is compiled in, no standard Xmu is avaiable, +dnl X11 support is compiled in, no standard Xmu is available, dnl or dragndrop support is disabled dnl Because OffiX support currently loses when more than one display dnl is in use, we now disable it by default -slb 07/10/1998. @@ -3390,7 +3396,7 @@ case "$with_sound" in both | nas ) XE_ADD_OBJS(nas.o) XE_PREPEND(-laudio, libs_x) dnl If the nas library does not contain the error jump point, - dnl then we force safer behaviour. + dnl then we force safer behavior. AC_EGREP_HEADER(AuXtErrorJump,audio/Xtutil.h,,[AC_DEFINE(NAS_NO_ERROR_JUMP)]) esac @@ -3652,7 +3658,7 @@ XE_SPACE(ld_libs_all, $ld_libs_window_system $ld_libs_general) dnl Compute lists of Makefiles and subdirs AC_SUBST(SRC_SUBDIR_DEPS) XE_APPEND(src, MAKE_SUBDIR) -internal_makefile_list="Makefile" +internal_makefile_list="Makefile.in" SUBDIR_MAKEFILES='' test -d lock || mkdir lock for dir in $MAKE_SUBDIR; do @@ -3864,7 +3870,13 @@ AC_SUBST(sound_cflags) AC_SUBST(RANLIB) AC_SUBST(dynodump_arch) -# The default is yes +dnl Preliminary support for using a different compiler for xemacs itself. +dnl Useful for building XEmacs with a C++ or 64-bit compiler. +: ${XEMACS_CC:=$CC} +AC_SUBST(XEMACS_CC) + + +dnl The default is yes if test "$with_site_lisp" = "no"; then AC_DEFINE(INHIBIT_SITE_LISP) fi @@ -3900,9 +3912,9 @@ fi test "$with_i18n3" = "yes" && AC_DEFINE(I18N3) test "$GCC" = "yes" && AC_DEFINE(USE_GCC) test "$external_widget" = "yes" && AC_DEFINE(EXTERNAL_WIDGET) -test "$with_gnu_make" = "yes" && AC_DEFINE(USE_GNU_MAKE) test "$no_doc_file" = "yes" && AC_DEFINE(NO_DOC_FILE) dnl test "$const_is_losing" = "yes" && AC_DEFINE(CONST_IS_LOSING) +test "$with_purify" = "yes" && AC_DEFINE(PURIFY) test "$with_quantify" = "yes" && AC_DEFINE(QUANTIFY) test "$with_pop" = "yes" && AC_DEFINE(MAIL_USE_POP) test "$with_kerberos" = "yes" && AC_DEFINE(KERBEROS) @@ -3999,7 +4011,7 @@ case "$with_sound" in native ) echo " Compiling in native sound support." ;; both ) echo " Compiling in both network and native sound support." ;; esac -test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously" +test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously." test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB." test "$with_database_dbm" = yes && echo " Compiling in support for DBM." @@ -4053,9 +4065,9 @@ test "$with_shlib" = "yes" && echo " Compiling in DLL support." test "$with_clash_detection" = yes && \ echo " Clash detection will use \"$lockdir\" for locking files." echo " movemail will use \"$mail_locking\" for locking mail spool files." -test "$with_pop" = yes && echo " Using POP for mail access" -test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" -test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" +test "$with_pop" = yes && echo " Using POP for mail access." +test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication." +test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host." test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$use_minimal_tagbits" = yes && echo " Using Lisp_Objects with minimal tagbits." test "$use_indexed_lrecord_implementation" = yes && echo " Using indexed lrecord implementation." @@ -4083,7 +4095,6 @@ echo '")' >> Installation.el dnl ----------------------------------- dnl Now generate config.h and Makefiles dnl ----------------------------------- - dnl This has to be called in order for this variable to get into config.status AC_SUBST(internal_makefile_list) # Remove any trailing slashes in these variables. @@ -4103,41 +4114,57 @@ done ac_output_files="$ac_output_files src/paths.h lib-src/config.values" AC_OUTPUT($ac_output_files, -[for dir in $MAKE_SUBDIR; do - echo creating $dir/Makefile +[for dir in . $MAKE_SUBDIR; do ( -changequote(<<, >>)dnl cd $dir rm -f junk.c < Makefile.in \ sed -e '/^# Generated/d' \ -e 's%/\*\*/#.*%%' \ -e 's/^ *# */#/' \ +dnl Delete Makefile.in.in comment lines -e '/^##/d' \ +dnl Pass through CPP directives unchanged -e '/^#/ { p d -}' -e '/./ { -s/\([\"]\)/\\\1/g +}' \ +dnl Quote other lines to protect from CPP substitution + -e '/./ { +s/\([[\"]]\)/\\\1/g s/^/"/ s/$/"/ }' > junk.c; - $CPP -I. -I${top_srcdir}/src $CPPFLAGS junk.c > junk.cpp; - < junk.cpp \ - sed -e 's/^#.*//' \ - -e 's/^[ TAB][ TAB]*$//' \ - -e 's/^ /TAB/' \ - | sed -n -e '/^..*$/p' \ - | sed '/^"/ { -s/\\\([\"]\)/\1/g -s/^[ TAB]*"// -s/"[ TAB]*$// -}' > Makefile.new + +dnl Create a GNUmakefile and Makefile from Makefile.in. + +changequote(<<,>>)dnl +dnl CPP_MAKEFILE(CPPFLAGS,filename) +define(<>, +echo creating $dir/<<$2>> +$CPP -I. -I${top_srcdir}/src <<$1>> junk.c \ +dnl Delete line directives inserted by $CPP + | sed -e 's/^\#.*//' \ +dnl Delete spurious blanks inserted by $CPP + -e 's/^[ TAB][ TAB]*$//'\ + -e 's/^ /TAB/' \ +dnl Delete blank lines + | sed -n -e '/^..*$/p' \ +dnl Restore lines quoted above to original contents. + | sed '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ TAB]*\"// + s/\"[ TAB]*$// +}' > Makefile.new chmod 444 Makefile.new - mv -f Makefile.new Makefile - rm -f junk.c junk.cpp -changequote([, ])dnl -) + mv -f Makefile.new <<$2>> +)dnl CPP_MAKEFILE + + CPP_MAKEFILE(,Makefile) + CPP_MAKEFILE(-DUSE_GNU_MAKE,GNUmakefile) +changequote([,])dnl + rm -f junk.c + ) done dnl Append AC_DEFINE information to lib-src/config.values @@ -4150,7 +4177,6 @@ sed < config.status >> lib-src/config.values \ ], [CPP="$CPP" - CPPFLAGS="$CPPFLAGS" top_srcdir="$srcdir" MAKE_SUBDIR="$MAKE_SUBDIR" -]) +])dnl diff --git a/configure.usage b/configure.usage index dfb58d9..fe0004b 100644 --- a/configure.usage +++ b/configure.usage @@ -3,7 +3,7 @@ Usage: configure [--OPTION[=VALUE] ...] [CONFIGURATION] Set compilation and installation parameters for XEmacs, and report. Note that for most of the following options, you can explicitly enable -them using `--OPTION=yes' and explicitly disable them using `--OPTION=no'. +them using `--OPTION=yes' and explicitly disable them using `--OPTION=no'. This is especially useful for auto-detected options. The option `--without-FEATURE' is a synonym for `--with-FEATURE=no'. @@ -24,11 +24,6 @@ Compilation options: --compiler=prog C compiler to use. --with-gcc (*) Use GCC to compile XEmacs. --without-gcc Don't use GCC to compile XEmacs. ---with-gnu-make Write the Makefiles to take advantage of - special features of GNU Make. (GNU Make - works fine on the Makefiles even without this - option. This just allows for simultaneous - in-place and --srcdir building.) --cflags=FLAGS Compiler flags (such as -O) --cpp=prog C preprocessor to use (e.g. /usr/ccs/lib/cpp or cc -E) --cppflags=FLAGS C preprocessor flags (e.g. -I/foo or -Dfoo=bar) @@ -46,7 +41,7 @@ Compilation options: --dynamic=no Force static linking on systems where dynamic linking is the default. --srcdir=DIR Look for the XEmacs source files in DIR. - See also --with-gnu-make. + Works best when using GNU Make. --use-indexed-lrecord-implementation --use-minimal-tagbits --gung-ho Build with new-style Lisp_Objects. @@ -124,7 +119,7 @@ Additional features: --with-socks Compile with support for SOCKS (an Internet proxy). --with-database=TYPE (*) Compile with database support. Valid types are `no' or a comma-separated list of one or more - of `dbm', `gnudbm', or `berkdb'. + of `berkdb' and either `dbm' or `gnudbm'. --with-sound=native (*) Compile with native sound support. --with-sound=nas Compile with network sound support. --with-sound=both Compile with native and network sound support. @@ -140,17 +135,17 @@ Additional features: --mail-locking=TYPE (*) Specify the locking to be used by movemail to prevent concurrent updates of mail spool files. Valid types are `lockf', `flock', and `file'. ---with-site-lisp Allow for a site-lisp directory in the XEmacs hierarchy +--with-site-lisp Allow for a site-lisp directory in the XEmacs hierarchy searched before the installation packages. --package-path=PATH Directories to search for packages to dump with xemacs. PATH splits into three parts separated by double colons (::), an early, a late, and a last part, corresponding to their position in the various - system paths: The early part is always first, - the late part somewhere in the middle, and the + system paths: The early part is always first, + the late part somewhere in the middle, and the last part at the very back. Only the late part gets seen at dump time. - If PATH has only one component, that component + If PATH has only one component, that component is late. If PATH has two components, the first is early, the second is late. @@ -221,6 +216,8 @@ Other options: Defaults to `${statedir}/xemacs/lock'. --with-system-malloc Force use of the system malloc, rather than GNU malloc. --with-debug-malloc Use the debugging malloc package. +--with-quantify Add support for performance debugging using Quantify. +--with-purify Add support for memory debugging using Purify. You may also specify any of the `path' variables found in Makefile.in, including --bindir, --libdir, --lispdir, --sitelispdir, --datadir, diff --git a/etc/MOTIVATION b/etc/MOTIVATION index 37ed36f..267a233 100644 --- a/etc/MOTIVATION +++ b/etc/MOTIVATION @@ -96,7 +96,7 @@ about rewards and performance. First, rewards encourage people to focus narrowly on a task, to do it as quickly as possible and to take few risks. "If they feel that -'this is something I hve to get through to get the prize,' the're +'this is something I have to get through to get the prize,' they're going to be less creative," Amabile said. Second, people come to see themselves as being controlled by the diff --git a/etc/NEWS b/etc/NEWS index 7190dbd..30d5eb2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -9,7 +9,7 @@ history. Use `C-c C-f' to move to the next equal level of outline, and `C-c C-b' to move to previous equal level. `C-h m' will give more -info about the Outline mode. Many commands are also available through +info about the Outline mode. Many commands are also available through the menubar. Users who would like to know which capabilities have been introduced @@ -54,13 +54,73 @@ indirect). `buffer-indirect-children' returns a list of the indirect children of a base buffer. -* Lisp and internal changes in XEmacs 21.0 +* Lisp and internal changes in XEmacs 21.2 ========================================== ** Functions for decoding base64 encoding are now available; see `base64-encode-region', `base64-encode-string', `base64-decode-region' and `base64-decode-string'. +** Many basic lisp operations are now faster. +This is especially the case when running a Mule-enabled XEmacs. + +A general overhaul of the lisp engine should produce a speedup of 1.4 +in a Latin-1 XEmacs, and 2.1 in a Mule XEmacs. These numbers were +obtained running (byte-compile "simple.el"), which should be a pretty +typical test of `pure' lisp. + +Lisp hash tables have been re-implemented. The Common Lisp style hash +table interface has been made standard, and moved from cl.el into fast +C code (See the section on hash tables in the XEmacs Lisp Reference). +A speedup factor of 3 can be expected with code that makes intensive +use of hash tables. + +The garbage collector has been tuned, leading to a speedup of 1.16. + +The family of functions that iterate over lists, like `memq', and +`rassq', have been made a little faster (typically 1.3). + +Lisp function calls are faster, by approximately a factor of two. +However, defining inline functions (via defsubst) still make sense. + +And finally, a few functions have had dramatic performance +improvements. For example, (last long-list) is now 30 times faster. + +Of course, your mileage will vary. + +Many operations do not see any improvement. Surprisingly, running +(font-lock-refontify-buffer) does not use the Lisp engine much at all. +Speeding up your favorite slow operation is an excellent project to +improve XEmacs. Don't forget to profile! + +** XEmacs finally has an automated test suite! +Although this is not yet very sophisticated, it is already responsible +for several important bug fixes in XEmacs. To try it out, simply use +the makefile target `make check' after building XEmacs. + +** New hash table implementation +As was pointed out above, the standard interface to hash tables is now +the Common Lisp interface, as described in Common Lisp, the Language +(CLtL2, by Steele). The older interface (functions with names +containing the phrase `hashtable') will continue to work, but the +preferred interface now has names containing the phrase `hash-table'. + +Here's the executive overview: create hash tables using +make-hash-table, and use gethash, puthash, remhash, maphash and +clrhash to manipulate entries in the hash table. See the (updated) +Lisp Reference Manual for details. + +** Lisp code handles circular lists much more robustly. +Many basic lisp functions used to loop forever when given a circular +list. Now this is more likely to trigger a `circular-list' error. +Printing a circular list now results in something like this: + + (progn (setq x (cons 'foo 'foo)) (setcdr x x) x) +==> (foo ... ) + +An extra bonus is that checking for circularities is not just +friendlier, but actually faster than checking for quit. + * Changes in XEmacs 21.0 ======================== @@ -111,15 +171,15 @@ and then through inexact matches, as one would expect. ** The new variable `user-full-name' can be used to customize one's name when using the Emacs mail and news reading facilities. -Normally, `user-full-name' is a function that returns the full name of +Normally, `user-full-name' is a function that returns the full name of a user or UID, as specified by the system -- for instance, -(user-full-name "root") returns something like "Super-User". However, +(user-full-name "root") returns something like "Super-User". However, when the function is called without arguments, it will return the -value of the `user-full-name' variable. The `user-full-name' variable +value of the `user-full-name' variable. The `user-full-name' variable is initialized using the environment variable NAME and (failing that) the user's system name. -The behaviour of the `user-full-name' function with an argument +The behavior of the `user-full-name' function with an argument specified is unchanged. ** The new command `M-x customize-changed-options' lets you customize @@ -278,7 +338,7 @@ limit. *** \\1-expressions are now valid in `nnmail-split-methods'. -*** The `custom-face-lookup' function has been removed. +*** The `custom-face-lookup' function has been removed. If you used this function in your initialization files, you must rewrite them to use `face-spec-set' instead. @@ -328,7 +388,7 @@ updated by the `gnus-start-date-timer' command. subsystem. If the `dir' file does not exist in an Info directory, the relevant information will be generated on-the-fly. -This behaviour can be customized, look for `Info-auto-generate-directory' +This behavior can be customized, look for `Info-auto-generate-directory' and `Info-save-auto-generated-dir' in the `info' customization group. @@ -368,7 +428,7 @@ this is set to nil, the vertical dividers between windows are shown only when needed, and they are not draggable. Other properties of the vertical dividers may be controlled using -`vertical-divider-shadow-thickness', `vertical-divider-line-width' and +`vertical-divider-shadow-thickness', `vertical-divider-line-width' and `vertical-divider-spacing' specifiers, which see. ** Frame focus management changes. @@ -440,7 +500,7 @@ instance: ** It is now possible to build XEmacs with LDAP support. You will need to install a LDAP library first. The following have been tested: - - LDAP 3.3 from the University of Michigan + - LDAP 3.3 from the University of Michigan (get it from ) - LDAP SDK 1.0 from Netscape Corp. (get it from ) diff --git a/lib-src/ChangeLog b/lib-src/ChangeLog index d3738c9..51232db 100644 --- a/lib-src/ChangeLog +++ b/lib-src/ChangeLog @@ -1,3 +1,7 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff --git a/lib-src/gnuclient.c b/lib-src/gnuclient.c index db30ee3..4fd2771 100644 --- a/lib-src/gnuclient.c +++ b/lib-src/gnuclient.c @@ -553,7 +553,7 @@ main (int argc, char *argv[]) if (read_line (s, buffer) == 0) { - fprintf (stderr, "%s: Could not establish Emacs procces id\n", + fprintf (stderr, "%s: Could not establish Emacs process id\n", progname); exit (1); } diff --git a/lib-src/gnuserv.c b/lib-src/gnuserv.c index 39f9147..ddce69c 100644 --- a/lib-src/gnuserv.c +++ b/lib-src/gnuserv.c @@ -563,7 +563,7 @@ add_host (u_long host_addr) /* - setup_table -- initialise the table of hosts allowed to contact the server, + setup_table -- initialize the table of hosts allowed to contact the server, by reading from the file specified by the GNU_SECURE environment variable Put in the local machine, and, if a security file is specifed, @@ -832,9 +832,7 @@ handle_unix_request (int ls) int -main(argc,argv) - int argc; - char *argv[]; +main (int argc, char *argv[]) { int chan; /* temporary channel number */ #ifdef SYSV_IPC @@ -867,7 +865,7 @@ main(argc,argv) #endif /* SYSV_IPC */ #ifdef INTERNET_DOMAIN_SOCKETS - ils = internet_init(); /* get a internet domain socket to listen on */ + ils = internet_init(); /* get an internet domain socket to listen on */ #endif /* INTERNET_DOMAIN_SOCKETS */ #ifdef UNIX_DOMAIN_SOCKETS diff --git a/lib-src/make-docfile.c b/lib-src/make-docfile.c index 2db8dc8..467b388 100644 --- a/lib-src/make-docfile.c +++ b/lib-src/make-docfile.c @@ -1032,7 +1032,7 @@ scan_lisp_file (CONST char *filename, CONST char *mode) else { #ifdef DEBUG - fprintf (stderr, "## unrecognised top-level form, %s (%s)\n", + fprintf (stderr, "## unrecognized top-level form, %s (%s)\n", buffer, filename); #endif continue; diff --git a/lib-src/make-msgfile.c b/lib-src/make-msgfile.c index 118dd1f..31b9379 100644 --- a/lib-src/make-msgfile.c +++ b/lib-src/make-msgfile.c @@ -69,7 +69,7 @@ This program (make-msgfile.c) addresses the first part, extracting the strings. - For the emacs C code, we need to recognise the following patterns: + For the emacs C code, we need to recognize the following patterns: message ("string" ... ) error ("string") @@ -94,7 +94,7 @@ there are no alphabetic characters in it that are not a part of a `%' directive. (Careful not to translate either "%s%s" or "%s: ".) - For the emacs Lisp code, we need to recognise the following patterns: + For the emacs Lisp code, we need to recognize the following patterns: (message "string" ... ) (error "string" ... ) @@ -109,7 +109,7 @@ I expect there will be a lot like the above; basically, any function which is a commonly used wrapper around an eventual call to `message' or - `read-from-minibuffer' needs to be recognised by this program. + `read-from-minibuffer' needs to be recognized by this program. (dgettext "domain-name" "string") #### do we still need this? @@ -124,7 +124,7 @@ Menu descriptors: one way to extract the strings in menu labels would be to teach this program about "^(defvar .*menu\n" forms; that's probably kind of hard, though, so perhaps a better approach would be to make this - program recognise lines of the form + program recognize lines of the form "string" ... ;###translate diff --git a/lib-src/make-msgfile.lex b/lib-src/make-msgfile.lex index 957a8b5..21a050a 100644 --- a/lib-src/make-msgfile.lex +++ b/lib-src/make-msgfile.lex @@ -134,7 +134,7 @@ Boston, MA 02111-1307, USA. */ This program (make-msgfile.c) addresses the first part, extracting the strings. - For the emacs C code, we need to recognise the following patterns: + For the emacs C code, we need to recognize the following patterns: message ("string" ... ) error ("string") @@ -159,7 +159,7 @@ Boston, MA 02111-1307, USA. */ there are no alphabetic characters in it that are not a part of a `%' directive. (Careful not to translate either "%s%s" or "%s: ".) - For the emacs Lisp code, we need to recognise the following patterns: + For the emacs Lisp code, we need to recognize the following patterns: (message "string" ... ) (error "string" ... ) @@ -174,7 +174,7 @@ Boston, MA 02111-1307, USA. */ I expect there will be a lot like the above; basically, any function which is a commonly used wrapper around an eventual call to `message' or - `read-from-minibuffer' needs to be recognised by this program. + `read-from-minibuffer' needs to be recognized by this program. (dgettext "domain-name" "string") #### do we still need this? @@ -218,7 +218,7 @@ Boston, MA 02111-1307, USA. */ Menu descriptors: one way to extract the strings in menu labels would be to teach this program about "^(defvar .*menu\n" forms; that's probably kind of hard, though, so perhaps a better approach would be to make this - program recognise lines of the form + program recognize lines of the form "string" ... ;###translate diff --git a/lib-src/movemail.c b/lib-src/movemail.c index f345020..ac257d9 100644 --- a/lib-src/movemail.c +++ b/lib-src/movemail.c @@ -68,7 +68,7 @@ Boston, MA 02111-1307, USA. */ #include "getopt.h" #ifdef MAIL_USE_POP #include "pop.h" -#include +#include "../src/regex.h" #endif extern char *optarg; @@ -847,7 +847,7 @@ mbx_delimit_end (FILE *mbf) /* Turn a name, which is an ed-style (but Emacs syntax) regular expression, into a real regular expression by compiling it. */ static struct re_pattern_buffer* -compile_regex (char* regexp_pattern) +compile_regex (char* pattern) { char *err; struct re_pattern_buffer *patbuf=0; @@ -858,7 +858,7 @@ compile_regex (char* regexp_pattern) patbuf->buffer = NULL; patbuf->allocated = 0; - err = (char*) re_compile_pattern (regexp_pattern, strlen (regexp_pattern), patbuf); + err = (char*) re_compile_pattern (pattern, strlen (pattern), patbuf); if (err != NULL) { error ("%s while compiling pattern", err, NULL); diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 92e8583..422ee0c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,204 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + +1998-12-05 SL Baur + + * files.el (binary-file-regexps): regexp-opt is not available at + bytecompile time. + +1998-11-30 Martin Buchholz + + * x-win-xfree86.el: + * x-win-sun.el (x-win-init-sun): + * x-win-sun.el: + * x-mouse.el (mouse-track-and-copy-to-cutbuffer): + * x-iso8859-1.el: + * x-init.el (init-post-x-win): + * x-init.el (init-pre-x-win): + * x-init.el (x-initialize-compose): + * x-init.el: + * x-compose.el: + * winnt.el: + * widget.el: + * wid-edit.el (widget-glyph-click): + * wid-edit.el (widget-glyph-find): + * wid-edit.el (widget-type): + * view-less.el (view-buffer-other-window): + * very-early-lisp.el: + * version.el: + * toolbar.el: + * toolbar-items.el: + * term/sun.el (suntool-map): + * term/sun-mouse.el: + * term/internal.el: + * syntax.el (modify-syntax-entry): + * symbol-syntax.el: + * subr.el: + * startup.el (lock-directory): + * simple.el (set-comment-column): + * simple.el (backward-delete-char-untabify): + * shadow.el (find-emacs-lisp-shadows): + * shadow.el: + * setup-paths.el (paths-construct-info-path): + * select.el (cut-copy-clear-internal): + * process.el (call-process-region): + * process.el (start-process-shell-command): + * process.el: + * paths.el (rmail-spool-directory): + * paragraphs.el (use-hard-newlines): + * package-get.el (package-get-dependencies): + * package-admin.el (package-admin-delete-binary-package): + * obsolete.el (truncate-string): + * obsolete.el (store-substring): + * mouse.el (default-mouse-track-maybe-own-selection): + * mouse.el (mouse-yank-at-point): + * modeline.el: + * modeline.el (mouse-drag-modeline): + * minibuf.el (read-directory-name-internal): + * minibuf.el (read-file-name-internal): + * minibuf.el (read-file-name-internal-1): + * minibuf.el (read-file-name-2): + * minibuf.el (exact-minibuffer-completion-p): + * minibuf.el (read-from-minibuffer): + * minibuf.el: + * menubar.el (check-menu-syntax): + * map-ynp.el (map-y-or-n-p): + * make-docfile.el (docfile-out-of-date): + * loadup.el ((member "run-temacs" command-line-args)): + * loadup.el ((member "no-site-file" command-line-args)): + * loadup.el (really-early-error-handler): + * loadup.el: + * loadhist.el: + * loaddefs.el: + * lisp-mnt.el (lm-verify): + * lib-complete.el (lib-complete:cache-completions): + * lib-complete.el (library-all-completions): + * itimer.el (itimer-run-expired-timers): + * info.el (Info-mode): + * info.el (Info-insert-file-contents): + * info.el (Info-rebuild-dir): + * info.el (Info-build-dir-anew): + * info.el (Info-parse-dir-entries): + * info.el (Info-dir-outdated-p): + * info.el (Info-insert-dir): + * info.el (info-xref): + * info.el: + * hyper-apropos.el (hyper-apropos-get-doc): + * hyper-apropos.el (hyper-describe-face): + * hyper-apropos.el (hyper-apropos-mode): + * hyper-apropos.el: + * help.el (list-processes): + * help.el: + * gnuserv.el: + * font.el (mswindows-font-create-name): + * font.el (font-default-font-for-device): + * font.el (x-font-create-object): + * font.el (font-registry): + * font.el: + * font-lock.el (font-lock-keywords): + * font-lock.el: + * finder.el (finder-compile-keywords): + * find-paths.el (paths-find-recursive-path): + * fill.el (set-justification-center): + * fill.el (fill-region-as-paragraph): + * files.el (insert-directory): + * files.el (wildcard-to-regexp): + * files.el (recover-file): + * files.el (basic-save-buffer): + * files.el (delete-auto-save-file-if-necessary): + * files.el (file-relative-name): + * files.el (backup-extract-version): + * files.el (backup-buffer): + * files.el (set-visited-file-name): + * files.el (set-auto-mode): + * files.el (interpreter-mode-alist): + * files.el: + * files.el (find-file-noselect): + * files.el (abbreviate-file-name): + * files.el (parse-colon-path): + * files.el (directory-abbrev-alist): + * etags.el (visit-tags-table-buffer): + * easymenu.el (easy-menu-define): + * dragdrop.el (experimental-dragdrop-drag): + * dragdrop.el (dragdrop-drop-do-functions): + * dragdrop.el (dragdrop-drop-at-point): + * disass.el (disassemble-1): + * disass.el (disassemble-internal): + * disass.el (disassemble): + * disass.el: + * derived.el (derived-mode-init-mode-variables): + * derived.el (define-derived-mode): + * custom.el (defgroup): + * cus-edit.el (custom-quote): + * config.el: + * code-process.el (open-network-stream): + * code-process.el (start-process): + * code-process.el (call-process-region): + * code-process.el (call-process): + * code-process.el: + * code-files.el (insert-file-contents): + * code-files.el: + * code-files.el (buffer-file-coding-system-for-read): + * cmdloop.el (yes-or-no-p-minibuf): + * cl.el: + * cl-macs.el: + * cl-extra.el: + * callers-of-rpt.el (make-caller-report): + * callers-of-rpt.el: + * bytecomp.el (batch-byte-recompile-directory): + * bytecomp.el (batch-byte-compile-1): + * bytecomp.el (batch-byte-compile): + * bytecomp.el (display-call-tree): + * bytecomp.el (byte-compile-insert): + * bytecomp.el (byte-compile-two-args-19->20): + * bytecomp.el (byte-compile-variable-ref): + * bytecomp.el (byte-compile-form): + * bytecomp.el (byte-compile-top-level-body): + * bytecomp.el (byte-compile-out-toplevel): + * bytecomp.el (byte-compile-byte-code-maker): + * bytecomp.el (byte-compile-file-form-defmumble): + * bytecomp.el (byte-compile-file-form): + * bytecomp.el (byte-compile-keep-pending): + * bytecomp.el (byte-compile-insert-header): + * bytecomp.el (byte-compile-from-buffer): + * bytecomp.el (byte-compile-file): + * bytecomp.el (byte-recompile-file): + * bytecomp.el (byte-compile-close-variables): + * bytecomp.el (byte-compile-warn-about-unused-variables): + * bytecomp.el (byte-compile-warn-about-unresolved-functions): + * bytecomp.el (byte-compiler-legal-options): + * bytecomp.el (byte-compile-lapcode): + * bytecomp.el (byte-optimize-log): + * bytecomp.el ((fboundp 'defsubst)): + * bytecomp.el: + * bytecomp-runtime.el: + * byte-optimize.el (byte-optimize-apply): + * byte-optimize.el (car): + * byte-optimize.el (byte-optimize-form): + * byte-optimize.el (byte-optimize-form-code-walker): + * byte-optimize.el: + * build-report.el (build-report-insert-installation-file): + * build-report.el (build-report): + * auto-show.el: + * apropos.el (apropos-documentation): + - mega patch + - clean up byte-compile warnings + - remove unused variables + - Use common lisp style hashtable functions + - byte compiler cleanup + - use #'(lambda ...) instead of '(lambda ...) or (function (lambda ...)) + - remove old backquote syntax usage + - move some cl functionality into C for speed. + - remove last remaining VMS support + - spelling fixes + - implement last, butlast, nbutlast, copy-list in C. + - new macro ignore-file-errors, similar to ignore-errors + (ignore-file-errors (delete-file "foo")) + - get frequent garbage collection during loadup.el by tweaking + gc-cons-threshold, rather than explicitly calling garbage-collect + - default delete-key-deletes-forward to `t'. + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. @@ -362,7 +563,7 @@ mswindows-make-font-bold / -bold-italic: Supplied device was not being passed into call to mswindows-find-smaller-font. -1998-09-10 Björn Torkelsson +1998-09-10 Bjrn Torkelsson * package-get.el (package-get-remote): Fix the path where to find the packages on xemacs.org. diff --git a/lisp/apropos.el b/lisp/apropos.el index c7857dd..5839194 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -309,7 +309,7 @@ Returns list of symbols and documentation found." (lambda (symbol) (setq f (apropos-safe-documentation symbol) v (get symbol 'variable-documentation)) - (if (integerp v) (setq v)) + (when (integerp v) (setq v nil)) (setq f (apropos-documentation-internal f) v (apropos-documentation-internal v)) (if (or f v) diff --git a/lisp/auto-show.el b/lisp/auto-show.el index d8140f5..9e44467 100644 --- a/lisp/auto-show.el +++ b/lisp/auto-show.el @@ -140,8 +140,7 @@ actually do any horizontal scrolling; rather, it just sets things up so that the region will be visible when `auto-show-make-point-visible' is next called (this happens after every command)." (if (auto-show-should-take-action-p) - (let* ((col (current-column)) ;column on line point is at - (scroll (window-hscroll));how far window is scrolled + (let* ((scroll (window-hscroll)) ;how far window is scrolled (w-width (- (window-width) (if (> scroll 0) 2 1))) ;how wide window is on the screen diff --git a/lisp/build-report.el b/lisp/build-report.el index 1700496..5e33dc5 100644 --- a/lisp/build-report.el +++ b/lisp/build-report.el @@ -169,6 +169,7 @@ make output and errors and leaves point at the beginning of the mail text. (prompts build-report-prompts)) (progn (while prompts + (defvar hist) (setq prompt (caar prompts)) (setq hist (cdar prompts)) (setq prompts (cdr prompts)) @@ -283,12 +284,12 @@ created by the XEmacs Beta configure process." (defun build-report-keep () "build-report-internal function of no general value." - (mapconcat '(lambda (item) item) + (mapconcat #'identity (cons "^--\\[\\[\\|\\]\\]$" build-report-keep-regexp) "\\|")) (defun build-report-delete () "build-report-internal function of no general value." - (mapconcat '(lambda (item) item) + (mapconcat #'identity build-report-delete-regexp "\\|")) ;;; build-report.el ends here diff --git a/lisp/byte-optimize.el b/lisp/byte-optimize.el index fe99286..95e7cb4 100644 --- a/lisp/byte-optimize.el +++ b/lisp/byte-optimize.el @@ -1,4 +1,4 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler. +;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler. ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. @@ -39,7 +39,7 @@ ;; TO DO: ;; -;; (apply '(lambda (x &rest y) ...) 1 (foo)) +;; (apply #'(lambda (x &rest y) ...) 1 (foo)) ;; ;; maintain a list of functions known not to access any global variables ;; (actually, give them a 'dynamically-safe property) and then @@ -149,7 +149,7 @@ ;; in some grody way, but that's a really bad idea.) ;; ;; HA! RMS removed the following paragraph from his version of -;; byte-opt.el. +;; byte-optimize.el. ;; ;; Really the Right Thing is to make lexical scope the default across ;; the board, in the interpreter and compiler, and just FIX all of @@ -158,14 +158,14 @@ ;; Other things to consider: ;; Associative math should recognize subcalls to identical function: -;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) +;;(disassemble #'(lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) ;; This should generate the same as (1+ x) and (1- x) -;;(disassemble (lambda (x) (cons (+ x 1) (- x 1)))) +;;(disassemble #'(lambda (x) (cons (+ x 1) (- x 1)))) ;; An awful lot of functions always return a non-nil value. If they're ;; error free also they may act as true-constants. -;;(disassemble (lambda (x) (and (point) (foo)))) +;;(disassemble #'(lambda (x) (and (point) (foo)))) ;; When ;; - all but one arguments to a function are constant ;; - the non-constant argument is an if-expression (cond-expression?) @@ -174,20 +174,20 @@ ;; arguments may be any expressions. Since, however, the code size ;; can increase this way they should be "simple". Compare: -;;(disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) -;;(disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) +;;(disassemble #'(lambda (x) (eq (if (point) 'a 'b) 'c))) +;;(disassemble #'(lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) ;; (car (cons A B)) -> (progn B A) -;;(disassemble (lambda (x) (car (cons (foo) 42)))) +;;(disassemble #'(lambda (x) (car (cons (foo) 42)))) ;; (cdr (cons A B)) -> (progn A B) -;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) +;;(disassemble #'(lambda (x) (cdr (cons 42 (foo))))) ;; (car (list A B ...)) -> (progn B ... A) -;;(disassemble (lambda (x) (car (list (foo) 42 (bar))))) +;;(disassemble #'(lambda (x) (car (list (foo) 42 (bar))))) ;; (cdr (list A B ...)) -> (progn A (list B ...)) -;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) +;;(disassemble #'(lambda (x) (cdr (list 42 (foo) (bar))))) ;;; Code: @@ -199,31 +199,32 @@ (error "The old version of the disassembler is loaded. Reload new-bytecomp as well.")) (byte-compile-log-1 (apply 'format format - (let (c a) - (mapcar '(lambda (arg) - (if (not (consp arg)) - (if (and (symbolp arg) - (string-match "^byte-" (symbol-name arg))) - (intern (substring (symbol-name arg) 5)) - arg) - (if (integerp (setq c (car arg))) - (error "non-symbolic byte-op %s" c)) - (if (eq c 'TAG) - (setq c arg) - (setq a (cond ((memq c byte-goto-ops) - (car (cdr (cdr arg)))) - ((memq c byte-constref-ops) - (car (cdr arg))) - (t (cdr arg)))) - (setq c (symbol-name c)) - (if (string-match "^byte-." c) - (setq c (intern (substring c 5))))) - (if (eq c 'constant) (setq c 'const)) - (if (and (eq (cdr arg) 0) - (not (memq c '(unbind call const)))) - c - (format "(%s %s)" c a)))) - args))))) + (let (c a) + (mapcar + #'(lambda (arg) + (if (not (consp arg)) + (if (and (symbolp arg) + (string-match "^byte-" (symbol-name arg))) + (intern (substring (symbol-name arg) 5)) + arg) + (if (integerp (setq c (car arg))) + (error "non-symbolic byte-op %s" c)) + (if (eq c 'TAG) + (setq c arg) + (setq a (cond ((memq c byte-goto-ops) + (car (cdr (cdr arg)))) + ((memq c byte-constref-ops) + (car (cdr arg))) + (t (cdr arg)))) + (setq c (symbol-name c)) + (if (string-match "^byte-." c) + (setq c (intern (substring c 5))))) + (if (eq c 'constant) (setq c 'const)) + (if (and (eq (cdr arg) 0) + (not (memq c '(unbind call const)))) + c + (format "(%s %s)" c a)))) + args))))) (defmacro byte-compile-log-lap (format-string &rest args) (list 'and @@ -238,20 +239,21 @@ (defun byte-optimize-inline-handler (form) "byte-optimize-handler for the `inline' special-form." - (cons 'progn - (mapcar - '(lambda (sexp) - (let ((fn (car-safe sexp))) - (if (and (symbolp fn) - (or (cdr (assq fn byte-compile-function-environment)) - (and (fboundp fn) - (not (or (cdr (assq fn byte-compile-macro-environment)) - (and (consp (setq fn (symbol-function fn))) - (eq (car fn) 'macro)) - (subrp fn)))))) - (byte-compile-inline-expand sexp) - sexp))) - (cdr form)))) + (cons + 'progn + (mapcar + #'(lambda (sexp) + (let ((fn (car-safe sexp))) + (if (and (symbolp fn) + (or (cdr (assq fn byte-compile-function-environment)) + (and (fboundp fn) + (not (or (cdr (assq fn byte-compile-macro-environment)) + (and (consp (setq fn (symbol-function fn))) + (eq (car fn) 'macro)) + (subrp fn)))))) + (byte-compile-inline-expand sexp) + sexp))) + (cdr form)))) ;; Splice the given lap code into the current instruction stream. @@ -392,27 +394,29 @@ ;; are more deeply nested are optimized first. (cons fn (cons - (mapcar '(lambda (binding) - (if (symbolp binding) - binding - (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: %s" - (prin1-to-string binding))) - (list (car binding) - (byte-optimize-form (nth 1 binding) nil)))) - (nth 1 form)) + (mapcar + #'(lambda (binding) + (if (symbolp binding) + binding + (if (cdr (cdr binding)) + (byte-compile-warn "malformed let binding: %s" + (prin1-to-string binding))) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + (nth 1 form)) (byte-optimize-body (cdr (cdr form)) for-effect)))) ((eq fn 'cond) (cons fn - (mapcar '(lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: %s" - (prin1-to-string clause)) - clause)) - (cdr form)))) + (mapcar + #'(lambda (clause) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: %s" + (prin1-to-string clause)) + clause)) + (cdr form)))) ((eq fn 'progn) ;; as an extra added bonus, this simplifies (progn ) --> (if (cdr (cdr form)) @@ -542,7 +546,7 @@ ;; First, optimize all sub-forms of this one. (setq form (byte-optimize-form-code-walker form for-effect)) ;; - ;; after optimizing all subforms, optimize this form until it doesn't + ;; After optimizing all subforms, optimize this form until it doesn't ;; optimize any further. This means that some forms will be passed through ;; the optimizer many times, but that's necessary to make the for-effect ;; processing do as much as possible. @@ -564,10 +568,10 @@ (defun byte-optimize-body (forms all-for-effect) - ;; optimize the cdr of a progn or implicit progn; all forms is a list of + ;; Optimize the cdr of a progn or implicit progn; `forms' is a list of ;; forms, all but the last of which are optimized with the assumption that - ;; they are being called for effect. the last is for-effect as well if - ;; all-for-effect is true. returns a new list of forms. + ;; they are being called for effect. The last is for-effect as well if + ;; all-for-effect is true. Returns a new list of forms. (let ((rest forms) (result nil) fe new) @@ -592,9 +596,10 @@ ;; I'd like this to be a defsubst, but let's not be self-referential... (defmacro byte-compile-trueconstp (form) ;; Returns non-nil if FORM is a non-nil constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((eq (, form) t))))) + `(cond ((consp ,form) (eq (car ,form) 'quote)) + ((not (symbolp ,form))) + ((eq ,form t)) + ((keywordp ,form)))) ;; If the function is being called with constant numeric args, ;; evaluate as much as possible at compile-time. This optimizer @@ -899,7 +904,7 @@ ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie -;; I think this may some times be necessary to reduce ie (quote 5) to 5, +;; I think this may some times be necessary to reduce eg. (quote 5) to 5, ;; so arithmetic optimizers recognize the numeric constant. - Hallvard (put 'quote 'byte-optimizer 'byte-optimize-quote) (defun byte-optimize-quote (form) @@ -1052,7 +1057,7 @@ (if (listp (nth 1 last)) (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast - (mapcar '(lambda (x) (list 'quote x)) (nth 1 last)))) + (mapcar #'(lambda (x) (list 'quote x)) (nth 1 last)))) (byte-compile-warn "last arg to apply can't be a literal atom: %s" (prin1-to-string last)) @@ -1122,6 +1127,16 @@ file-newer-than-file-p file-readable-p file-symlink-p file-writable-p float floor format get get-buffer get-buffer-window getenv get-file-buffer + ;; hash-table functions + make-hash-table copy-hash-table + gethash + hash-table-count + hash-table-rehash-size + hash-table-rehash-threshold + hash-table-size + hash-table-test + hash-table-type + ;; int-to-string length log log10 logand logb logior lognot logxor lsh marker-buffer max member memq min mod @@ -1134,7 +1149,14 @@ ;; XEmacs change: window-edges -> window-pixel-edges window-buffer window-dedicated-p window-pixel-edges window-height window-hscroll window-minibuffer-p window-width - zerop)) + zerop + ;; functions defined by cl + oddp evenp plusp minusp + abs expt signum last butlast ldiff + pairlis gcd lcm + isqrt floor* ceiling* truncate* round* mod* rem* subseq + list-length get* getf + )) (side-effect-and-error-free-fns '(arrayp atom bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp @@ -1147,6 +1169,7 @@ dot dot-marker eobp eolp eq eql equal eventp extentp extent-live-p floatp framep frame-live-p get-largest-window get-lru-window + hash-table-p identity ignore integerp integer-or-marker-p interactive-p invocation-directory invocation-name ;; keymapp may autoload in XEmacs, so not on this list! @@ -1161,14 +1184,15 @@ user-full-name user-login-name user-original-login-name user-real-login-name user-real-uid user-uid vector vectorp - window-configuration-p window-live-p windowp))) - (while side-effect-free-fns - (put (car side-effect-free-fns) 'side-effect-free t) - (setq side-effect-free-fns (cdr side-effect-free-fns))) - (while side-effect-and-error-free-fns - (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free) - (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns))) - nil) + window-configuration-p window-live-p windowp + ;; Functions defined by cl + eql floatp-safe list* subst acons equalp random-state-p + copy-tree sublis + ))) + (dolist (fn side-effect-free-fns) + (put fn 'side-effect-free t)) + (dolist (fn side-effect-and-error-free-fns) + (put fn 'side-effect-free 'error-free))) (defun byte-compile-splice-in-already-compiled-code (form) @@ -1326,10 +1350,7 @@ (if endtag (setq lap (cons (cons nil endtag) lap))) ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) - (mapcar (function (lambda (elt) - (if (numberp elt) - elt - (cdr elt)))) + (mapcar #'(lambda (elt) (if (numberp elt) elt (cdr elt))) (nreverse lap)))) @@ -1953,17 +1974,18 @@ (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-optimize-form - byte-optimize-body - byte-optimize-predicate - byte-optimize-binary-predicate - ;; Inserted some more than necessary, to speed it up. - byte-optimize-form-code-walker - byte-optimize-lapcode)))) + (mapcar + #'(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-optimize-form + byte-optimize-body + byte-optimize-predicate + byte-optimize-binary-predicate + ;; Inserted some more than necessary, to speed it up. + byte-optimize-form-code-walker + byte-optimize-lapcode)))) nil) ;;; byte-optimize.el ends here diff --git a/lisp/bytecomp-runtime.el b/lisp/bytecomp-runtime.el index 105374a..95d8c31 100644 --- a/lisp/bytecomp-runtime.el +++ b/lisp/bytecomp-runtime.el @@ -55,13 +55,13 @@ They will only be compiled open-coded when `byte-optimize' is true." (apply 'nconc (mapcar - '(lambda (x) - (` ((or (memq (get '(, x) 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error - "%s already has a byte-optimizer, can't make it inline" - '(, x))) - (put '(, x) 'byte-optimizer 'byte-compile-inline-expand)))) + #'(lambda (x) + `((or (memq (get ',x 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error + "%s already has a byte-optimizer, can't make it inline" + ',x)) + (put ',x 'byte-optimizer 'byte-compile-inline-expand))) fns)))) @@ -71,10 +71,10 @@ They will only be compiled open-coded when `byte-optimize' is true." (apply 'nconc (mapcar - '(lambda (x) - (` ((if (eq (get '(, x) 'byte-optimizer) - 'byte-compile-inline-expand) - (put '(, x) 'byte-optimizer nil))))) + #'(lambda (x) + `((if (eq (get ',x 'byte-optimizer) + 'byte-compile-inline-expand) + (put ',x 'byte-optimizer nil)))) fns)))) ;; This has a special byte-hunk-handler in bytecomp.el. @@ -178,7 +178,7 @@ Called (eval-when-feature (FEATURE [. FILENAME]) BODYFORMS...). If (featurep 'FEATURE), evals now; otherwise adds an elt to `after-load-alist' (which see), using FEATURE as filename if FILENAME is nil." (let ((file (or (cdr feature) (symbol-name (car feature))))) - `(let ((bodythunk (function (lambda () ,@body)))) + `(let ((bodythunk #'(lambda () ,@body))) (if (featurep ',(car feature)) (funcall bodythunk) (setq after-load-alist (cons '(,file . (list 'lambda '() bodythunk)) diff --git a/lisp/bytecomp.el b/lisp/bytecomp.el index 4e0bd04..5340162 100644 --- a/lisp/bytecomp.el +++ b/lisp/bytecomp.el @@ -9,7 +9,7 @@ ;; Subsequently modified by RMS and others. -(defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96.")) +(defconst byte-compile-version (purecopy "2.26 XEmacs; 1998-10-07.")) ;; This file is part of XEmacs. @@ -101,6 +101,8 @@ ;;; 'unresolved (calls to unknown functions) ;;; 'callargs (lambda calls with args that don't ;;; match the lambda's definition) +;;; 'subr-callargs (calls to subrs with args that +;;; don't match the subr's definition) ;;; 'redefine (function cell redefined from ;;; a macro to a lambda or vice versa, ;;; or redefined to take other args) @@ -171,7 +173,7 @@ ;;; buffer, and that buffer is modified, you are asked whether you want ;;; to save the buffer before compiling. ;;; -;;; o You can add this to /etc/magic to make file(1) recognise the files +;;; o You can add this to /etc/magic to make file(1) recognize the files ;;; generated by this compiler: ;;; ;;; 0 string ;ELC GNU Emacs Lisp compiled file, @@ -210,17 +212,16 @@ be hard-coded into bytecomp when it compiles itself. If the compiler itself is compiled with optimization, this causes a speedup.") - (cond (byte-compile-single-version - (defmacro byte-compile-single-version () t) - (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) - (t - (defmacro byte-compile-single-version () nil) - (defmacro byte-compile-version-cond (cond) cond))) + (cond + (byte-compile-single-version + (defmacro byte-compile-single-version () t) + (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) + (t + (defmacro byte-compile-single-version () nil) + (defmacro byte-compile-version-cond (cond) cond))) ) -(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) - (purecopy "\\.EL\\(;[0-9]+\\)?$") - (purecopy "\\.el$")) +(defvar emacs-lisp-file-regexp (purecopy "\\.el$") "*Regexp which matches Emacs Lisp source files. You may want to redefine `byte-compile-dest-file' if you change this.") @@ -234,18 +235,16 @@ You may want to redefine `byte-compile-dest-file' if you change this.") (funcall handler 'byte-compiler-base-file-name filename) filename))) -(or (fboundp 'byte-compile-dest-file) - ;; The user may want to redefine this along with emacs-lisp-file-regexp, - ;; so only define it if it is undefined. - (defun byte-compile-dest-file (filename) - "Convert an Emacs Lisp source file name to a compiled file name." - (setq filename (byte-compiler-base-file-name filename)) - (setq filename (file-name-sans-versions filename)) - (cond ((eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c")) - ((string-match emacs-lisp-file-regexp filename) - (concat (substring filename 0 (match-beginning 0)) ".elc")) - (t (concat filename ".elc"))))) +(unless (fboundp 'byte-compile-dest-file) + ;; The user may want to redefine this along with emacs-lisp-file-regexp, + ;; so only define it if it is undefined. + (defun byte-compile-dest-file (filename) + "Convert an Emacs Lisp source file name to a compiled file name." + (setq filename (byte-compiler-base-file-name filename)) + (setq filename (file-name-sans-versions filename)) + (if (string-match emacs-lisp-file-regexp filename) + (concat (substring filename 0 (match-beginning 0)) ".elc") + (concat filename ".elc")))) ;; This can be the 'byte-compile property of any symbol. (autoload 'byte-compile-inline-expand "byte-optimize") @@ -260,7 +259,7 @@ You may want to redefine `byte-compile-dest-file' if you change this.") ;; disassembler. The disassembler just requires 'byte-compile, but ;; that doesn't define this function, so this seems to be a reasonable ;; thing to do. -(autoload 'byte-decompile-bytecode "byte-opt") +(autoload 'byte-decompile-bytecode "byte-optimize") (defvar byte-compile-verbose (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) @@ -350,7 +349,7 @@ If it is 'byte, then only byte-level optimizations will be logged.") ;; byte-compile-warning-types in FSF. (defvar byte-compile-default-warnings - '(redefine callargs free-vars unresolved unused-vars obsolete) + '(redefine callargs subr-callargs free-vars unresolved unused-vars obsolete) "*The warnings used when byte-compile-warnings is t.") (defvar byte-compile-warnings t @@ -361,6 +360,7 @@ Elements of the list may be: unused-vars references to non-global variables bound but not referenced. unresolved calls to unknown functions. callargs lambda calls with args that don't match the definition. + subr-callargs calls to subrs with args that don't match the definition. redefine function cell redefined from a macro to a lambda or vice versa, or redefined to take a different number of arguments. obsolete use of an obsolete function or variable. @@ -373,7 +373,7 @@ See also the macro `byte-compiler-options'.") (defvar byte-compile-generate-call-tree nil "*Non-nil means collect call-graph information when compiling. -This records functions were called and from where. +This records functions that were called and from where. If the value is t, compilation displays the call graph when it finishes. If the value is neither t nor nil, compilation asks you whether to display the graph. @@ -432,6 +432,7 @@ on the specbind stack. The cdr of each cell is an integer bitmask.") (defvar byte-compile-free-references) (defvar byte-compile-free-assignments) +(defvar debug-issue-ebola-notices) (defvar byte-compiler-error-flag) @@ -620,7 +621,7 @@ Each element is (INDEX . VALUE)") "to examine top-of-stack, jump and don't pop it if it's nil, otherwise pop it") (byte-defop 134 -1 byte-goto-if-not-nil-else-pop - "to examine top-of-stack, jump and don't pop it if it's non nil, + "to examine top-of-stack, jump and don't pop it if it's non-nil, otherwise pop it") (byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") @@ -770,13 +771,13 @@ otherwise pop it") (error "Non-symbolic opcode `%s'" op)) ((eq op 'TAG) (setcar off pc) - (setq patchlist (cons off patchlist))) + (push off patchlist)) ((memq op byte-goto-ops) (setq pc (+ pc 3)) (setq bytes (cons (cons pc (cdr off)) (cons nil (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) + (push bytes patchlist)) (t (setq bytes (cond ((cond ((consp off) @@ -859,81 +860,64 @@ otherwise pop it") (defvar byte-compile-dest-file nil) (defmacro byte-compile-log (format-string &rest args) - (list 'and - 'byte-optimize - '(memq byte-optimize-log '(t source)) - (list 'let '((print-escape-newlines t) - (print-level 4) - (print-length 4)) - (list 'byte-compile-log-1 - (cons 'format - (cons format-string - (mapcar - '(lambda (x) - (if (symbolp x) (list 'prin1-to-string x) x)) - args))))))) - -(defconst byte-compile-last-warned-form nil) + `(when (and byte-optimize (memq byte-optimize-log '(t source))) + (let ((print-escape-newlines t) + (print-level 4) + (print-length 4)) + (byte-compile-log-1 (format ,format-string ,@args))))) + +(defconst byte-compile-last-warned-form 'nothing) ;; Log a message STRING in *Compile-Log*. ;; Also log the current function and file if not already done. (defun byte-compile-log-1 (string &optional fill) - (let ((this-form (or byte-compile-current-form "toplevel forms"))) - (cond - (noninteractive - (if (or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq this-form byte-compile-last-warned-form)))) - (message - (format "While compiling %s%s:" - this-form - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (concat " in file " byte-compile-current-file) - (concat " in buffer " - (buffer-name byte-compile-current-file))) - "")))) - (message " %s" string)) - (t - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) + (let* ((this-form (or byte-compile-current-form "toplevel forms")) + (while-compiling-msg + (when (or byte-compile-current-file + (not (eq this-form byte-compile-last-warned-form))) + (format + "While compiling %s%s:" + this-form + (cond + ((stringp byte-compile-current-file) + (concat " in file " byte-compile-current-file)) + ((bufferp byte-compile-current-file) + (concat " in buffer " + (buffer-name byte-compile-current-file))) + ("")))))) + (if noninteractive + (progn + (when while-compiling-msg (message "%s" while-compiling-msg)) + (message " %s" string)) + (with-current-buffer (get-buffer-create "*Compile-Log*") (goto-char (point-max)) - (cond ((or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq this-form byte-compile-last-warned-form)))) - (if byte-compile-current-file - (insert "\n\^L\n" (current-time-string) "\n")) - (insert "While compiling " - (if (stringp this-form) this-form - (format "%s" this-form))) - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (insert " in file " byte-compile-current-file) - (insert " in buffer " - (buffer-name byte-compile-current-file)))) - (insert ":\n"))) + (when byte-compile-current-file + (when (> (point-max) (point-min)) + (insert "\n\^L\n")) + (insert (current-time-string) "\n")) + (when while-compiling-msg (insert while-compiling-msg "\n")) (insert " " string "\n") - (if (and fill (not (string-match "\n" string))) - (let ((fill-prefix " ") - (fill-column 78)) - (fill-paragraph nil))) - ))) - (setq byte-compile-current-file nil - byte-compile-last-warned-form this-form))) + (when (and fill (not (string-match "\n" string))) + (let ((fill-prefix " ") + (fill-column 78)) + (fill-paragraph nil))))) + (setq byte-compile-current-file nil) + (setq byte-compile-last-warned-form this-form))) ;; Log the start of a file in *Compile-Log*, and mark it as done. ;; But do nothing in batch mode. (defun byte-compile-log-file () - (and byte-compile-current-file (not noninteractive) - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (goto-char (point-max)) - (insert "\n\^L\nCompiling " - (if (stringp byte-compile-current-file) - (concat "file " byte-compile-current-file) - (concat "buffer " (buffer-name byte-compile-current-file))) - " at " (current-time-string) "\n") - (setq byte-compile-current-file nil)))) + (when (and byte-compile-current-file (not noninteractive)) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (when (> (point-max) (point-min)) + (goto-char (point-max)) + (insert "\n\^L\n")) + (insert "Compiling " + (if (stringp byte-compile-current-file) + (concat "file " byte-compile-current-file) + (concat "buffer " (buffer-name byte-compile-current-file))) + " at " (current-time-string) "\n") + (setq byte-compile-current-file nil)))) (defun byte-compile-warn (format &rest args) (setq format (apply 'format format args)) @@ -987,7 +971,7 @@ otherwise pop it") (verbose byte-compile-verbose (t nil) val) (new-bytecodes byte-compile-new-bytecodes (t nil) val) (warnings byte-compile-warnings - ((callargs redefine free-vars unused-vars unresolved)) + ((callargs subr-callargs redefine free-vars unused-vars unresolved)) val))) ;; XEmacs addition @@ -1225,7 +1209,7 @@ otherwise pop it") nil) (defun byte-compile-defvar-p (var) - ;; Whether the byte compiler thinks that nonexical references to this + ;; Whether the byte compiler thinks that non-lexical references to this ;; variable are ok. (or (globally-boundp var) (let ((rest byte-compile-bound-variables)) @@ -1257,7 +1241,7 @@ otherwise pop it") ;; have (declare (ignore x)) yet; and second, inline ;; expansion produces forms like ;; ((lambda (arg) (byte-code "..." [arg])) x) - ;; which we can't (ok, well, don't) recognise as + ;; which we can't (ok, well, don't) recognize as ;; containing a reference to arg, so every inline ;; expansion would generate a warning. (If we had ;; `ignore' then inline expansion could emit an @@ -1275,12 +1259,14 @@ otherwise pop it") (setq unreferenced (cdr unreferenced))))) +(defmacro byte-compile-constant-symbol-p (symbol) + `(or (keywordp ,symbol) (memq ,symbol '(nil t)))) + (defmacro byte-compile-constp (form) ;; Returns non-nil if FORM is a constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((keywordp (, form))) - ((memq (, form) '(nil t)))))) + `(cond ((consp ,form) (eq (car ,form) 'quote)) + ((symbolp ,form) (byte-compile-constant-symbol-p ,form)) + (t))) (defmacro byte-compile-close-variables (&rest body) `(let @@ -1313,6 +1299,9 @@ otherwise pop it") byte-compile-default-warnings byte-compile-warnings)) (byte-compile-file-domain nil) + + ;; We reserve the right to compare ANY objects for equality. + (debug-issue-ebola-notices -42) ) (prog1 (progn ,@body) @@ -1321,46 +1310,49 @@ otherwise pop it") (byte-compile-warn-about-unused-variables))))) -(defvar byte-compile-warnings-point-max nil) (defmacro displaying-byte-compile-warnings (&rest body) - `(let ((byte-compile-warnings-point-max byte-compile-warnings-point-max)) - ;; Log the file name. + `(let* ((byte-compile-log-buffer (get-buffer-create "*Compile-Log*")) + (byte-compile-point-max-prev (point-max byte-compile-log-buffer))) + ;; Log the file name or buffer name. (byte-compile-log-file) ;; Record how much is logged now. ;; We will display the log buffer if anything more is logged ;; before the end of BODY. - (or byte-compile-warnings-point-max - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (setq byte-compile-warnings-point-max (point-max)))) - (unwind-protect - (condition-case error-info - (progn ,@body) - (error - (byte-compile-report-error error-info))) - (save-excursion - ;; If there were compilation warnings, display them. - (set-buffer "*Compile-Log*") - (if (= byte-compile-warnings-point-max (point-max)) - nil - (if temp-buffer-show-function - (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) - (save-excursion - (set-buffer show-buffer) - (setq buffer-read-only nil) - (erase-buffer)) - (copy-to-buffer show-buffer - (save-excursion - (goto-char byte-compile-warnings-point-max) - (forward-line -1) - (point)) - (point-max)) - (funcall temp-buffer-show-function show-buffer)) - (select-window - (prog1 (selected-window) - (select-window (display-buffer (current-buffer))) - (goto-char byte-compile-warnings-point-max) - (recenter 1))))))))) + (defvar byte-compile-warnings-beginning) + (let ((byte-compile-warnings-beginning + (if (boundp 'byte-compile-warnings-beginning) + byte-compile-warnings-beginning + (point-max byte-compile-log-buffer)))) + + (unwind-protect + (condition-case error-info + (progn ,@body) + (error + (byte-compile-report-error error-info))) + + ;; Always set point in log to start of interesting output. + (with-current-buffer byte-compile-log-buffer + (let ((show-begin + (progn (goto-char byte-compile-point-max-prev) + (skip-chars-forward "\^L\n") + (point)))) + ;; If there were compilation warnings, display them. + (if temp-buffer-show-function + (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) + ;; Always clean show-buffer, even when not displaying it, + ;; so that misleading previous messages aren't left around. + (with-current-buffer show-buffer + (setq buffer-read-only nil) + (erase-buffer)) + (copy-to-buffer show-buffer show-begin (point-max)) + (when (< byte-compile-warnings-beginning (point-max)) + (funcall temp-buffer-show-function show-buffer))) + (when (< byte-compile-warnings-beginning (point-max)) + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char show-begin) + (recenter 1))))))))))) ;;;###autoload @@ -1466,8 +1458,6 @@ whether to compile it. Prefix argument 0 don't ask and recompile anyway." (y-or-n-p (concat "Compile " filename "? ")))))) (byte-compile-file filename)))) -(defvar kanji-flag nil) - ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -1503,7 +1493,6 @@ With prefix arg (noninteractively: 2nd arg), load the file after compiling." (message "Compiling %s..." filename)) (let (;;(byte-compile-current-file (file-name-nondirectory filename)) (byte-compile-current-file filename) - (debug-issue-ebola-notices 0) ; Hack -slb target-file input-buffer output-buffer byte-compile-dest-file) (setq target-file (byte-compile-dest-file filename)) @@ -1534,28 +1523,26 @@ With prefix arg (noninteractively: 2nd arg), load the file after compiling." (set-buffer output-buffer) (goto-char (point-max)) (insert "\n") ; aaah, unix. - (let ((vms-stmlf-recfm t)) - (setq target-file (byte-compile-dest-file filename)) - (or byte-compile-overwrite-file - (condition-case () - (delete-file target-file) - (error nil))) - (if (file-writable-p target-file) - (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki - (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt)) - (setq buffer-file-type t)) - (write-region 1 (point-max) target-file)) - ;; This is just to give a better error message than write-region - (signal 'file-error - (list "Opening output file" - (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") - target-file))) - (or byte-compile-overwrite-file - (condition-case () - (set-file-modes target-file (file-modes filename)) - (error nil)))) + (setq target-file (byte-compile-dest-file filename)) + (unless byte-compile-overwrite-file + (ignore-file-errors (delete-file target-file))) + (if (file-writable-p target-file) + (progn + (when (memq system-type '(ms-dos windows-nt)) + (defvar buffer-file-type) + (setq buffer-file-type t)) + (write-region 1 (point-max) target-file)) + ;; This is just to give a better error message than write-region + (signal 'file-error + (list "Opening output file" + (if (file-exists-p target-file) + "cannot overwrite file" + "directory not writable or nonexistent") + target-file))) + (or byte-compile-overwrite-file + (condition-case () + (set-file-modes target-file (file-modes filename)) + (error nil))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -1664,7 +1651,7 @@ With argument, insert value in current buffer after the form." ;; Compile the forms from the input buffer. (while (progn - (while (progn (skip-chars-forward " \t\n\^l") + (while (progn (skip-chars-forward " \t\n\^L") (looking-at ";")) (forward-line 1)) (not (eobp))) @@ -1767,25 +1754,26 @@ With argument, insert value in current buffer after the form." ;; extended characters are output properly and distinguished properly. ;; Otherwise, use `no-conversion' for maximum portability with non-Mule ;; Emacsen. - (if (featurep 'mule) - (if (save-excursion - (set-buffer byte-compile-inbuffer) - (goto-char (point-min)) - ;; mrb- There must be a better way than skip-chars-forward - (skip-chars-forward (concat (char-to-string 0) "-" - (char-to-string 255))) - (eq (point) (point-max))) - (setq buffer-file-coding-system 'no-conversion) - (insert "(require 'mule)\n;;;###coding system: escape-quoted\n") - (setq buffer-file-coding-system 'escape-quoted) - ;; Lazy loading not yet implemented for MULE files - ;; mrb - Fix this someday. - (save-excursion + (when (featurep 'mule) + (defvar buffer-file-coding-system) + (if (save-excursion (set-buffer byte-compile-inbuffer) - (setq byte-compile-dynamic nil - byte-compile-dynamic-docstrings nil)) - ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) - )) + (goto-char (point-min)) + ;; mrb- There must be a better way than skip-chars-forward + (skip-chars-forward (concat (char-to-string 0) "-" + (char-to-string 255))) + (eq (point) (point-max))) + (setq buffer-file-coding-system 'no-conversion) + (insert "(require 'mule)\n;;;###coding system: escape-quoted\n") + (setq buffer-file-coding-system 'escape-quoted) + ;; #### Lazy loading not yet implemented for MULE files + ;; mrb - Fix this someday. + (save-excursion + (set-buffer byte-compile-inbuffer) + (setq byte-compile-dynamic nil + byte-compile-dynamic-docstrings nil)) + ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) + )) ) @@ -1904,8 +1892,8 @@ list that represents a doc string reference. (nthcdr 300 byte-compile-output) (byte-compile-flush-pending)) (funcall handler form) - (if for-effect - (byte-compile-discard))) + (when for-effect + (byte-compile-discard))) (byte-compile-form form t)) nil) @@ -1939,7 +1927,7 @@ list that represents a doc string reference. (byte-compile-file-form form))))) ;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognise them. Most other things can be output +;; so make-docfile can recognize them. Most other things can be output ;; as byte-code. (put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) @@ -2106,32 +2094,32 @@ list that represents a doc string reference. (cons (list name nil nil) byte-compile-call-tree)))) (setq byte-compile-current-form name) ; for warnings - (if (memq 'redefine byte-compile-warnings) - (byte-compile-arglist-warn form macrop)) - (if byte-compile-verbose - (message "Compiling %s... (%s)" - ;; #### filename used free - (if filename (file-name-nondirectory filename) "") - (nth 1 form))) + (when (memq 'redefine byte-compile-warnings) + (byte-compile-arglist-warn form macrop)) + (defvar filename) ; #### filename used free + (when byte-compile-verbose + (message "Compiling %s... (%s)" + (if filename (file-name-nondirectory filename) "") + (nth 1 form))) (cond (that-one - (if (and (memq 'redefine byte-compile-warnings) - ;; hack hack: don't warn when compiling the stubs in - ;; bytecomp-runtime... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn - "%s defined multiple times, as both function and macro" - (nth 1 form))) + (when (and (memq 'redefine byte-compile-warnings) + ;; hack hack: don't warn when compiling the stubs in + ;; bytecomp-runtime... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) + (byte-compile-warn + "%s defined multiple times, as both function and macro" + (nth 1 form))) (setcdr that-one nil)) (this-one - (if (and (memq 'redefine byte-compile-warnings) - ;; hack: don't warn when compiling the magic internal - ;; byte-compiler macros in bytecomp-runtime.el... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn "%s %s defined multiple times in this file" - (if macrop "macro" "function") - (nth 1 form)))) + (when (and (memq 'redefine byte-compile-warnings) + ;; hack: don't warn when compiling the magic internal + ;; byte-compiler macros in bytecomp-runtime.el... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) + (byte-compile-warn "%s %s defined multiple times in this file" + (if macrop "macro" "function") + (nth 1 form)))) ((and (fboundp name) (or (subrp (symbol-function name)) (eq (car-safe (symbol-function name)) @@ -2145,8 +2133,7 @@ list that represents a doc string reference. (if macrop "macro" "function"))) ;; shadow existing definition (set this-kind - (cons (cons name nil) (symbol-value this-kind)))) - ) + (cons (cons name nil) (symbol-value this-kind))))) (let ((body (nthcdr 3 form))) (if (and (stringp (car body)) (symbolp (car-safe (cdr-safe body))) @@ -2345,11 +2332,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let* ((interactive (assq 'interactive (cdr (cdr fun))))) (nconc (list 'make-byte-code (list 'quote (nth 1 fun)) ;arglist - (nth 1 tmp) ;bytes - (nth 2 tmp) ;consts - (nth 3 tmp)) ;depth + (nth 1 tmp) ;instructions + (nth 2 tmp) ;constants + (nth 3 tmp)) ;stack-depth (cond ((stringp (nth 2 fun)) - (list (nth 2 fun))) ;doc + (list (nth 2 fun))) ;docstring (interactive (list nil))) (cond (interactive @@ -2371,8 +2358,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables (let ((new-bindings - (mapcar (function (lambda (x) - (cons x byte-compile-arglist-bit))) + (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit)) (and (memq 'free-vars byte-compile-warnings) (delq '&rest (delq '&optional (copy-sequence arglist))))))) @@ -2383,18 +2369,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (prog1 (car body) (setq body (cdr body))))) (int (assq 'interactive body))) - (let ((rest arglist)) - (while rest - (cond ((not (symbolp (car rest))) - (byte-compile-warn "non-symbol in arglist: %s" - (prin1-to-string (car rest)))) - ((memq (car rest) '(t nil)) - (byte-compile-warn "constant in arglist: %s" (car rest))) - ((and (char= ?\& (aref (symbol-name (car rest)) 0)) - (not (memq (car rest) '(&optional &rest)))) - (byte-compile-warn "unrecognised `&' keyword in arglist: %s" - (car rest)))) - (setq rest (cdr rest)))) + (dolist (arg arglist) + (cond ((not (symbolp arg)) + (byte-compile-warn "non-symbol in arglist: %S" arg)) + ((byte-compile-constant-symbol-p arg) + (byte-compile-warn "constant symbol in arglist: %s" arg)) + ((and (char= ?\& (aref (symbol-name arg) 0)) + (not (eq arg '&optional)) + (not (eq arg '&rest))) + (byte-compile-warn "unrecognized `&' keyword in arglist: %s" + arg)))) (cond (int ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) @@ -2555,8 +2539,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (if (eq (car (car rest)) 'byte-constant) (or (consp tmp) (and (symbolp tmp) - (not (keywordp tmp)) - (not (memq tmp '(nil t)))))) + (not (byte-compile-constant-symbol-p tmp))))) (if maycall (setq body (cons (list 'quote tmp) body))) (setq body (cons tmp body)))) @@ -2606,7 +2589,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; This is the recursive entry point for compiling each subform of an ;; expression. ;; If for-effect is non-nil, byte-compile-form will output a byte-discard -;; before terminating (ie no value will be left on the stack). +;; before terminating (ie. no value will be left on the stack). ;; A byte-compile handler may, when for-effect is non-nil, choose output code ;; which does not leave a value on the stack, and then set for-effect to nil ;; (to prevent byte-compile-form from outputting the byte-discard). @@ -2617,8 +2600,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-form (form &optional for-effect) (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) - ;; XEmacs addition: keywordp - (cond ((or (not (symbolp form)) (keywordp form) (memq form '(nil t))) + (cond ((or (not (symbolp form)) + (byte-compile-constant-symbol-p form)) (byte-compile-constant form)) ((and for-effect byte-compile-delete-errors) (setq for-effect nil)) @@ -2644,8 +2627,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-form form for-effect) (setq for-effect nil)) ((byte-compile-normal-call form))) - (if for-effect - (byte-compile-discard))) + (when for-effect + (byte-compile-discard))) (defun byte-compile-normal-call (form) (if byte-compile-generate-call-tree @@ -2658,12 +2641,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." (or (fboundp 'globally-boundp) (fset 'globally-boundp 'boundp)) (defun byte-compile-variable-ref (base-op var &optional varbind-flags) - (if (or (not (symbolp var)) (keywordp var) (memq var '(nil t))) - (byte-compile-warn (if (eq base-op 'byte-varbind) - "Attempt to let-bind %s %s" - "Variable reference to %s %s") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)) + (if (or (not (symbolp var)) (byte-compile-constant-symbol-p var)) + (byte-compile-warn + (case base-op + (byte-varref "Variable reference to %s %s") + (byte-varset "Attempt to set %s %s") + (byte-varbind "Attempt to let-bind %s %s")) + (if (symbolp var) "constant symbol" "non-symbol") + var) (if (and (get var 'byte-obsolete-variable) (memq 'obsolete byte-compile-warnings)) (let ((ob (get var 'byte-obsolete-variable))) @@ -2709,11 +2694,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-out base-op tmp))) (defmacro byte-compile-get-constant (const) - (` (or (if (stringp (, const)) - (assoc (, const) byte-compile-constants) - (assq (, const) byte-compile-constants)) - (car (setq byte-compile-constants - (cons (list (, const)) byte-compile-constants)))))) + `(or (if (stringp ,const) + (assoc ,const byte-compile-constants) + (assq ,const byte-compile-constants)) + (car (setq byte-compile-constants + (cons (list ,const) byte-compile-constants))))) ;; Use this when the value of a form is a constant. This obeys for-effect. (defun byte-compile-constant (const) @@ -2894,12 +2879,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-defop-compiler20 old-memq 2) (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) -(byte-defop-compiler (= byte-eqlsign) byte-compile-one-or-more-args) -(byte-defop-compiler (< byte-lss) byte-compile-one-or-more-args) -(byte-defop-compiler (> byte-gtr) byte-compile-one-or-more-args) -(byte-defop-compiler (<= byte-leq) byte-compile-one-or-more-args) -(byte-defop-compiler (>= byte-geq) byte-compile-one-or-more-args) -(byte-defop-compiler /= byte-compile-/=) (byte-defop-compiler get 2+1) (byte-defop-compiler nth 2) (byte-defop-compiler substring 2-3) @@ -2922,9 +2901,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-defop-compiler (rplacd byte-setcdr) 2) (byte-defop-compiler setcar 2) (byte-defop-compiler setcdr 2) -;; buffer-substring now has its own function. This used to be -;; 2+1, but now all args are optional. -(byte-defop-compiler buffer-substring) (byte-defop-compiler delete-region 2+1) (byte-defop-compiler narrow-to-region 2+1) (byte-defop-compiler (% byte-rem) 2) @@ -2954,55 +2930,56 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn "%s called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) + (when (memq 'subr-callargs byte-compile-warnings) + (byte-compile-warn "%s called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n)) ;; get run-time wrong-number-of-args error. (byte-compile-normal-call form)) (defun byte-compile-no-args (form) - (if (not (= (length form) 1)) - (byte-compile-subr-wrong-args form "none") - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (0 (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form "none")))) (defun byte-compile-one-arg (form) - (if (not (= (length form) 2)) - (byte-compile-subr-wrong-args form 1) - (byte-compile-form (car (cdr form))) ;; Push the argument - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (1 (byte-compile-form (car (cdr form))) ;; Push the argument + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 1)))) (defun byte-compile-two-args (form) - (if (not (= (length form) 3)) - (byte-compile-subr-wrong-args form 2) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (2 (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 2)))) (defun byte-compile-three-args (form) - (if (not (= (length form) 4)) - (byte-compile-subr-wrong-args form 3) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-form (nth 3 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (3 (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-form (nth 3 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 3)))) (defun byte-compile-zero-or-one-arg (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) + (case (length (cdr form)) + (0 (byte-compile-one-arg (append form '(nil)))) + (1 (byte-compile-one-arg form)) + (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-one-or-two-args (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) + (case (length (cdr form)) + (1 (byte-compile-two-args (append form '(nil)))) + (2 (byte-compile-two-args form)) + (t (byte-compile-subr-wrong-args form "1-2")))) (defun byte-compile-two-or-three-args (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) + (case (length (cdr form)) + (2 (byte-compile-three-args (append form '(nil)))) + (3 (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "2-3")))) ;; from Ben Wing : some inlined functions have extra ;; optional args added to them in XEmacs 19.12. Changing the byte @@ -3013,55 +2990,55 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; `byte-compile-subr-wrong-args' also converts the call to non-inlined. (defun byte-compile-no-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-no-args form)) - ((= len 2) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) + (case (length (cdr form)) + (0 (byte-compile-no-args form)) + (1 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-one-arg-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-one-arg form)) - ((= len 3) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) + (case (length (cdr form)) + (1 (byte-compile-one-arg form)) + (2 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-2")))) (defun byte-compile-two-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) + (case (length (cdr form)) + (2 (byte-compile-two-args form)) + (3 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "2-3")))) (defun byte-compile-zero-or-one-arg-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - ((= len 3) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-2"))))) + (case (length (cdr form)) + (0 (byte-compile-one-arg (append form '(nil)))) + (1 (byte-compile-one-arg form)) + (2 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-2")))) (defun byte-compile-one-or-two-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-3"))))) + (case (length (cdr form)) + (1 (byte-compile-two-args (append form '(nil)))) + (2 (byte-compile-two-args form)) + (3 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-3")))) (defun byte-compile-two-or-three-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - ((= len 5) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "2-4"))))) + (case (length (cdr form)) + (2 (byte-compile-three-args (append form '(nil)))) + (3 (byte-compile-three-args form)) + (4 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "2-4")))) (defun byte-compile-no-args-with-two-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-no-args form)) - ((or (= len 2) (= len 3)) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-2"))))) + (case (length (cdr form)) + (0 (byte-compile-no-args form)) + ((1 2) (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-2")))) (defun byte-compile-one-arg-with-two-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-one-arg form)) - ((or (= len 3) (= len 4)) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-3"))))) + (case (length (cdr form)) + (1 (byte-compile-one-arg form)) + ((2 3) (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-3")))) ;; XEmacs: used for functions that have a different opcode in v19 than v20. ;; this includes `eq', `equal', and other old-ified functions. @@ -3080,21 +3057,33 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-discard () (byte-compile-out 'byte-discard 0)) +;; Compile a function that accepts one or more args and is right-associative. +;; We do it by left-associativity so that the operations +;; are done in the same order as in interpreted code. +;(defun byte-compile-associative (form) +; (if (cdr form) +; (let ((opcode (get (car form) 'byte-opcode)) +; (args (copy-sequence (cdr form)))) +; (byte-compile-form (car args)) +; (setq args (cdr args)) +; (while args +; (byte-compile-form (car args)) +; (byte-compile-out opcode 0) +; (setq args (cdr args)))) +; (byte-compile-constant (eval form)))) ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations ;; are done in the same order as in interpreted code. (defun byte-compile-associative (form) - (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - (args (copy-sequence (cdr form)))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (while args - (byte-compile-form (car args)) - (byte-compile-out opcode 0) - (setq args (cdr args)))) - (byte-compile-constant (eval form)))) + (let ((args (cdr form)) + (opcode (get (car form) 'byte-opcode))) + (case (length args) + (0 (byte-compile-constant (eval form))) + (t (byte-compile-form (car args)) + (dolist (arg (cdr args)) + (byte-compile-form arg) + (byte-compile-out opcode 0)))))) ;; more complicated compiler macros @@ -3109,20 +3098,32 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-defop-compiler nconc) (byte-defop-compiler-1 beginning-of-line) -(defun byte-compile-one-or-more-args (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) - ((= len 2) (byte-compile-constant t)) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-normal-call form))))) +(byte-defop-compiler (= byte-eqlsign) byte-compile-arithcompare) +(byte-defop-compiler (< byte-lss) byte-compile-arithcompare) +(byte-defop-compiler (> byte-gtr) byte-compile-arithcompare) +(byte-defop-compiler (<= byte-leq) byte-compile-arithcompare) +(byte-defop-compiler (>= byte-geq) byte-compile-arithcompare) + +(defun byte-compile-arithcompare (form) + (case (length (cdr form)) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant t)) + (2 (byte-compile-two-args form)) + (t (byte-compile-normal-call form)))) + +(byte-defop-compiler /= byte-compile-/=) (defun byte-compile-/= (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) - ((= len 2) (byte-compile-constant t)) - ;; optimize (/= X Y) to (not (= X Y)) - ((= len 3) (byte-compile-form-do-effect `(not (= ,@(cdr form))))) - (t (byte-compile-normal-call form))))) + (case (length (cdr form)) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant t)) + ;; optimize (/= X Y) to (not (= X Y)) + (2 (byte-compile-form-do-effect `(not (= ,@(cdr form))))) + (t (byte-compile-normal-call form)))) + +;; buffer-substring now has its own function. This used to be +;; 2+1, but now all args are optional. +(byte-defop-compiler buffer-substring) (defun byte-compile-buffer-substring (form) ;; buffer-substring used to take exactly two args, but now takes 0-3. @@ -3136,65 +3137,71 @@ If FORM is a lambda or a macro, byte-compile it as a function." (t (byte-compile-subr-wrong-args form "0-3")))) (defun byte-compile-list (form) - (let ((count (length (cdr form)))) - (cond ((= count 0) - (byte-compile-constant nil)) - ((< count 5) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) - ((< count 256) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-listN count)) - (t (byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args))) + (cond + ((= nargs 0) + (byte-compile-constant nil)) + ((< nargs 5) + (mapcar 'byte-compile-form args) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs)) + 0)) + ((< nargs 256) + (mapcar 'byte-compile-form args) + (byte-compile-out 'byte-listN nargs)) + (t (byte-compile-normal-call form))))) (defun byte-compile-concat (form) - (let ((count (length (cdr form)))) - (cond ((and (< 1 count) (< count 5)) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) - 0)) - ;; Concat of one arg is not a no-op if arg is not a string. - ((= count 0) - (byte-compile-form "")) - ((< count 256) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-concatN count)) - ((byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args))) + ;; Concat of one arg is not a no-op if arg is not a string. + (cond + ((memq nargs '(2 3 4)) + (mapcar 'byte-compile-form args) + (byte-compile-out + (aref [byte-concat2 byte-concat3 byte-concat4] (- nargs 2)) + 0)) + ((eq nargs 0) + (byte-compile-form "")) + ((< nargs 256) + (mapcar 'byte-compile-form args) + (byte-compile-out 'byte-concatN nargs)) + ((byte-compile-normal-call form))))) (defun byte-compile-minus (form) - (if (null (setq form (cdr form))) - (byte-compile-constant 0) - (byte-compile-form (car form)) - (if (cdr form) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-diff 0)) - (byte-compile-out 'byte-negate 0)))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-form (car args)) + (byte-compile-out 'byte-negate 0)) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-diff 0)))))) (defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((<= len 2) - (byte-compile-subr-wrong-args form "2 or more")) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-quo 0)))))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant 1) + (byte-compile-form (car args)) + (byte-compile-out 'byte-quo 0)) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-quo 0)))))) (defun byte-compile-nconc (form) - (let ((len (length form))) - (cond ((= len 1) - (byte-compile-constant nil)) - ((= len 2) - ;; nconc of one arg is a noop, even if that arg isn't a list. - (byte-compile-form (nth 1 form))) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-nconc 0)))))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-constant nil)) + ;; nconc of one arg is a noop, even if that arg isn't a list. + (1 (byte-compile-form (car args))) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-nconc 0)))))) (defun byte-compile-fset (form) ;; warn about forms like (fset 'foo '(lambda () ...)) @@ -3203,19 +3210,18 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; I'm sick of getting mail asking me whether that warning is a problem. (let ((fn (nth 2 form)) body) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (setq fn (nth 1 fn))) 'lambda) - (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) - (progn - (setq body (cdr (cdr fn))) - (if (stringp (car body)) (setq body (cdr body))) - (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) - (if (and (consp (car body)) - (not (eq 'byte-code (car (car body))))) - (byte-compile-warn - "A quoted lambda form is the second argument of fset. This is probably + (when (and (eq (car-safe fn) 'quote) + (eq (car-safe (setq fn (nth 1 fn))) 'lambda) + (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) + (setq body (cdr (cdr fn))) + (if (stringp (car body)) (setq body (cdr body))) + (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) + (if (and (consp (car body)) + (not (eq 'byte-code (car (car body))))) + (byte-compile-warn + "A quoted lambda form is the second argument of fset. This is probably not what you want, as that lambda cannot be compiled. Consider using - the syntax (function (lambda (...) ...)) instead."))))) + the syntax (function (lambda (...) ...)) instead.")))) (byte-compile-two-args form)) (defun byte-compile-funarg (form) @@ -3255,8 +3261,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (while (setq form (cdr form)) (byte-compile-form (car form)) (byte-compile-out 'byte-insert 0) - (if (cdr form) - (byte-compile-discard)))))) + (when (cdr form) + (byte-compile-discard)))))) ;; alas, the old (pre-19.12, and all existing versions of FSFmacs 19) ;; byte compiler will generate incorrect code for @@ -3290,76 +3296,82 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-defop-compiler-1 quote-form) (defun byte-compile-setq (form) - (let ((args (cdr form))) - (if args - (while args - (byte-compile-form (car (cdr args))) - (or for-effect (cdr (cdr args)) + (let ((args (cdr form)) var val) + (if (null args) + ;; (setq), with no arguments. + (byte-compile-form nil for-effect) + (while args + (setq var (pop args)) + (if (null args) + ;; Odd number of args? Let `set' get the error. + (byte-compile-form `(set ',var) for-effect) + (setq val (pop args)) + (if (keywordp var) + ;; (setq :foo ':foo) compatibility kludge + (byte-compile-form `(set ',var ,val) (if args t for-effect)) + (byte-compile-form val) + (unless (or args for-effect) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car args)) - (setq args (cdr (cdr args)))) - ;; (setq), with no arguments. - (byte-compile-form nil for-effect)) - (setq for-effect nil))) + (byte-compile-variable-ref 'byte-varset var)))))) + (setq for-effect nil)) (defun byte-compile-set (form) ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so ;; that we get applicable warnings. Compile everything else (including ;; malformed calls) like a normal 2-arg byte-coded function. - (if (or (not (eq (car-safe (nth 1 form)) 'quote)) - (not (= (length form) 3)) - (not (= (length (nth 1 form)) 2))) - (byte-compile-two-args form) - (byte-compile-setq (list 'setq (nth 1 (nth 1 form)) (nth 2 form))))) + (let ((symform (nth 1 form)) + (valform (nth 2 form)) + sym) + (if (and (= (length form) 3) + (= (safe-length symform) 2) + (eq (car symform) 'quote) + (symbolp (setq sym (car (cdr symform)))) + (not (byte-compile-constant-symbol-p sym))) + (byte-compile-setq `(setq ,sym ,valform)) + (byte-compile-two-args form)))) (defun byte-compile-setq-default (form) - (let ((rest (cdr form))) - ;; emit multiple calls to set-default if necessary - (while rest - (byte-compile-form - (list 'set-default (list 'quote (car rest)) (car (cdr rest))) - (not (null (cdr (cdr rest))))) - (setq rest (cdr (cdr rest)))))) + (let ((args (cdr form))) + (if (null args) + ;; (setq-default), with no arguments. + (byte-compile-form nil for-effect) + ;; emit multiple calls to `set-default' if necessary + (while args + (byte-compile-form + ;; Odd number of args? Let `set-default' get the error. + `(set-default ',(pop args) ,@(if args (list (pop args)) nil)) + (if args t for-effect))))) + (setq for-effect nil)) + (defun byte-compile-set-default (form) - (let ((rest (cdr form))) - (if (cdr (cdr (cdr form))) - ;; emit multiple calls to set-default if necessary; all but last - ;; for-effect (this recurses.) - (while rest - (byte-compile-form - (list 'set-default (car rest) (car (cdr rest))) - (not (null (cdr rest)))) - (setq rest (cdr (cdr rest)))) - ;; else, this is the one-armed version - (let ((var (nth 1 form)) - ;;(val (nth 2 form)) - ) - ;; notice calls to set-default/setq-default for variables which - ;; have not been declared with defvar/defconst. - (if (and (memq 'free-vars byte-compile-warnings) - (or (null var) - (and (eq (car-safe var) 'quote) - (= 2 (length var))))) - (let ((sym (nth 1 var)) - cell) - (or (and sym (symbolp sym) (globally-boundp sym)) - (and (setq cell (assq sym byte-compile-bound-variables)) - (setcdr cell (logior (cdr cell) - byte-compile-assigned-bit))) - (memq sym byte-compile-free-assignments) - (if (or (not (symbolp sym)) (memq sym '(t nil))) - (progn - (byte-compile-warn - "Attempt to set-globally %s %s" - (if (symbolp sym) "constant" "nonvariable") - (prin1-to-string sym))) - (progn - (byte-compile-warn "assignment to free variable %s" sym) - (setq byte-compile-free-assignments - (cons sym byte-compile-free-assignments))))))) - ;; now emit a normal call to set-default (or possibly multiple calls) - (byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args)) + (var (car args))) + (when (and (= (safe-length var) 2) + (eq (car var) 'quote)) + (let ((sym (nth 1 var))) + (cond + ((not (symbolp sym)) + (byte-compile-warn "Attempt to set-globally non-symbol %s" sym)) + ((byte-compile-constant-symbol-p sym) + (byte-compile-warn "Attempt to set-globally constant symbol %s" sym)) + ((let ((cell (assq sym byte-compile-bound-variables))) + (and cell + (setcdr cell (logior (cdr cell) byte-compile-assigned-bit)) + t))) + ;; notice calls to set-default/setq-default for variables which + ;; have not been declared with defvar/defconst. + ((globally-boundp sym)) ; OK + ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed? + ((memq sym byte-compile-free-assignments)) ; already warned about sym + (t + (byte-compile-warn "assignment to free variable %s" sym) + (push sym byte-compile-free-assignments))))) + (if (= nargs 2) + ;; now emit a normal call to set-default + (byte-compile-normal-call form) + (byte-compile-subr-wrong-args form 2)))) (defun byte-compile-quote (form) @@ -3408,20 +3420,22 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-body-do-effect (cdr form))) (defun byte-compile-prog1 (form) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-body (cdr (cdr form)) t)) + (setq form (cdr form)) + (byte-compile-form-do-effect (pop form)) + (byte-compile-body form t)) (defun byte-compile-prog2 (form) - (byte-compile-form (nth 1 form) t) - (byte-compile-form-do-effect (nth 2 form)) - (byte-compile-body (cdr (cdr (cdr form))) t)) + (setq form (cdr form)) + (byte-compile-form (pop form) t) + (byte-compile-form-do-effect (pop form)) + (byte-compile-body form t)) (defmacro byte-compile-goto-if (cond discard tag) - (` (byte-compile-goto - (if (, cond) - (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) - (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) - (, tag)))) + `(byte-compile-goto + (if ,cond + (if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) + (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) + ,tag)) (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) @@ -3827,7 +3841,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-out-tag (tag) - (setq byte-compile-output (cons tag byte-compile-output)) + (push tag byte-compile-output) (if (cdr (cdr tag)) (progn ;; ## remove this someday @@ -3838,7 +3852,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setcdr (cdr tag) byte-compile-depth))) (defun byte-compile-goto (opcode tag) - (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) + (push (cons opcode tag) byte-compile-output) (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) (1- byte-compile-depth) byte-compile-depth)) @@ -3846,20 +3860,21 @@ If FORM is a lambda or a macro, byte-compile it as a function." (1- byte-compile-depth)))) (defun byte-compile-out (opcode offset) - (setq byte-compile-output (cons (cons opcode offset) byte-compile-output)) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) + (push (cons opcode offset) byte-compile-output) + (case opcode + (byte-call + (setq byte-compile-depth (- byte-compile-depth offset))) + (byte-return + ;; This is actually an unnecessary case, because there should be + ;; no more opcodes behind byte-return. + (setq byte-compile-depth nil)) + (t + (setq byte-compile-depth (+ byte-compile-depth + (or (aref byte-stack+-info + (symbol-value opcode)) + (- (1- offset)))) + byte-compile-maxdepth (max byte-compile-depth + byte-compile-maxdepth)))) ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) ) @@ -3873,18 +3888,15 @@ If FORM is a lambda or a macro, byte-compile it as a function." (or (memq byte-compile-current-form (nth 1 entry)) ;callers (setcar (cdr entry) (cons byte-compile-current-form (nth 1 entry)))) - (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) - byte-compile-call-tree))) + (push (list (car form) (list byte-compile-current-form) nil) + byte-compile-call-tree)) ;; annotate the current function (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) (or (memq (car form) (nth 2 entry)) ;called (setcar (cdr (cdr entry)) (cons (car form) (nth 2 entry)))) - (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (push (list byte-compile-current-form nil (list (car form))) + byte-compile-call-tree)))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -3923,19 +3935,19 @@ invoked interactively." (sort byte-compile-call-tree (cond ((eq byte-compile-call-tree-sort 'callers) - (function (lambda (x y) (< (length (nth 1 x)) - (length (nth 1 y)))))) + #'(lambda (x y) (< (length (nth 1 x)) + (length (nth 1 y))))) ((eq byte-compile-call-tree-sort 'calls) - (function (lambda (x y) (< (length (nth 2 x)) - (length (nth 2 y)))))) + #'(lambda (x y) (< (length (nth 2 x)) + (length (nth 2 y))))) ((eq byte-compile-call-tree-sort 'calls+callers) - (function (lambda (x y) (< (+ (length (nth 1 x)) - (length (nth 2 x))) - (+ (length (nth 1 y)) - (length (nth 2 y))))))) + #'(lambda (x y) (< (+ (length (nth 1 x)) + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y)))))) ((eq byte-compile-call-tree-sort 'name) - (function (lambda (x y) (string< (car x) - (car y))))) + #'(lambda (x y) (string< (car x) + (car y)))) (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" byte-compile-call-tree-sort)))))) @@ -4031,8 +4043,7 @@ For example, invoke \"xemacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "`batch-byte-compile' is to be used only with -batch")) - (let ((error nil) - (debug-issue-ebola-notices 0)) ; Hack -slb + (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) (let ((files (directory-files (car command-line-args-left))) @@ -4065,7 +4076,7 @@ For example, invoke \"xemacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" (if (fboundp 'display-error) ; XEmacs 19.8+ (display-error err nil) (princ (or (get (car err) 'error-message) (car err))) - (mapcar '(lambda (x) (princ " ") (prin1 x)) (cdr err))) + (mapcar #'(lambda (x) (princ " ") (prin1 x)) (cdr err))) (princ "\n") nil))) @@ -4086,8 +4097,7 @@ For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." (error "batch-byte-recompile-directory is to be used only with -batch")) (or command-line-args-left (setq command-line-args-left '("."))) - (let ((byte-recompile-directory-ignore-errors-p t) - (debug-issue-ebola-notices 0)) + (let ((byte-recompile-directory-ignore-errors-p t)) (while command-line-args-left (byte-recompile-directory (car command-line-args-left)) (setq command-line-args-left (cdr command-line-args-left)))) @@ -4140,10 +4150,10 @@ For example, invoke `xemacs -batch -f batch-byte-recompile-directory .'." (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (mapcar #'(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) '(byte-compile-normal-call byte-compile-form byte-compile-body diff --git a/lisp/callers-of-rpt.el b/lisp/callers-of-rpt.el index 8e9c7fc..104e882 100644 --- a/lisp/callers-of-rpt.el +++ b/lisp/callers-of-rpt.el @@ -40,8 +40,8 @@ "Where the package lisp sources live.") ;; (makunbound 'caller-table) -(defconst caller-table (make-hashtable 256 #'equal) - "Hashtable keyed on the symbols being required. Each element will +(defconst caller-table (make-hash-table :test 'equal) + "Hash table keyed on the symbols being required. Each element will be a list of file-names of programs that depend on them.") ;;./apel/atype.el:(require 'emu) @@ -91,7 +91,8 @@ (point)) cmd-out)) (lst (gethash key caller-table))) - (puthash key (add-to-list 'lst file-name) caller-table)) + (unless (member file-name lst) + (puthash key (cons file-name lst) caller-table))) (forward-line 1) (sit-for 0)) (switch-to-buffer rpt) diff --git a/lisp/cl-extra.el b/lisp/cl-extra.el index 0d469a7..e419fe3 100644 --- a/lisp/cl-extra.el +++ b/lisp/cl-extra.el @@ -48,6 +48,8 @@ ;;; Code: +(eval-when-compile + (require 'obsolete)) (or (memq 'cl-19 features) (error "Tried to load `cl-extra' before `cl'!")) @@ -468,7 +470,7 @@ Optional second arg STATE is a random-state object." ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) - (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii) + (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) (aset state 3 (setq vec (make-vector 55 nil))) (aset vec 0 j) (while (> (setq i (% (+ i 21) 55)) 0) @@ -502,7 +504,7 @@ If STATE is t, return a new state object seeded from the time of day." ;; Implementation limits. (defun cl-finite-do (func a b) - (condition-case err + (condition-case nil (let ((res (funcall func a b))) ; check for IEEE infinity (and (numberp res) (/= res (/ res 2)) res)) (arith-error nil))) @@ -531,14 +533,14 @@ If STATE is t, return a new state object seeded from the time of day." most-negative-float (- x)) ;; Divide down until mantissa starts rounding. (setq x (/ x z) y (/ 16 z) x (* x y)) - (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) + (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) (arith-error nil)) (setq x (/ x 2) y (/ y 2))) (setq least-positive-normalized-float y least-negative-normalized-float (- y)) ;; Divide down until value underflows to zero. (setq x (/ 1 z) y x) - (while (condition-case err (> (/ x 2) 0) (arith-error nil)) + (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) (setq least-positive-float x least-negative-float (- x)) @@ -581,11 +583,11 @@ If STATE is t, return a new state object seeded from the time of day." (defun concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." - (cond ((eq type 'vector) (apply 'vconcat seqs)) - ((eq type 'string) (apply 'concat seqs)) - ((eq type 'list) (apply 'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) - + (case type + (vector (apply 'vconcat seqs)) + (string (apply 'concat seqs)) + (list (apply 'append (append seqs '(nil)))) + (t (error "Not a sequence type name: %s" type)))) ;;; List functions. @@ -666,142 +668,43 @@ PROPLIST is a list of the sort returned by `symbol-plist'." ;;; Hash tables. -(defun make-hash-table (&rest cl-keys) - "Make an empty Common Lisp-style hash-table. -If :test is `eq', `eql', or `equal', this can use XEmacs built-in hash-tables. -In Emacs 19, or with a different test, this internally uses a-lists. -Keywords supported: :test :size -The Common Lisp keywords :rehash-size and :rehash-threshold are ignored." - (let ((cl-test (or (car (cdr (memq ':test cl-keys))) 'eql)) - (cl-size (or (car (cdr (memq ':size cl-keys))) 20))) - ;; XEmacs change - (if (and (memq cl-test '(eq eql equal)) (fboundp 'make-hashtable)) - (funcall 'make-hashtable cl-size cl-test) - (list 'cl-hash-table-tag cl-test - (if (> cl-size 1) (make-vector cl-size 0) - (let ((sym (make-symbol "--hashsym--"))) (set sym nil) sym)) - 0)))) - -(defvar cl-lucid-hash-tag - (if (and (fboundp 'make-hashtable) (vectorp (make-hashtable 1))) - (aref (make-hashtable 1) 0) (make-symbol "--cl-hash-tag--"))) - -(defun hash-table-p (x) - "Return t if OBJECT is a hash table." - (or (and (fboundp 'hashtablep) (funcall 'hashtablep x)) - (eq (car-safe x) 'cl-hash-table-tag) - (and (vectorp x) (= (length x) 4) (eq (aref x 0) cl-lucid-hash-tag)))) - -(defun cl-not-hash-table (x &optional y &rest z) - (signal 'wrong-type-argument (list 'hash-table-p (or y x)))) - -(defun cl-hash-lookup (key table) - (or (eq (car-safe table) 'cl-hash-table-tag) (cl-not-hash-table table)) - (let* ((array (nth 2 table)) (test (car (cdr table))) (str key) sym) - (if (symbolp array) (setq str nil sym (symbol-value array)) - (while (or (consp str) (and (vectorp str) (> (length str) 0))) - (setq str (elt str 0))) - (cond ((stringp str) (if (eq test 'equalp) (setq str (downcase str)))) - ((symbolp str) (setq str (symbol-name str))) - ((and (numberp str) (> str -8000000) (< str 8000000)) - (or (integerp str) (setq str (truncate str))) - (setq str (aref ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" - "11" "12" "13" "14" "15"] (logand str 15)))) - (t (setq str "*"))) - (setq sym (symbol-value (intern-soft str array)))) - (list (and sym (cond ((or (eq test 'eq) - (and (eq test 'eql) (not (numberp key)))) - (assq key sym)) - ((memq test '(eql equal)) (assoc key sym)) - (t (assoc* key sym ':test test)))) - sym str))) - -(defvar cl-builtin-gethash - (if (and (fboundp 'gethash) (subrp (symbol-function 'gethash))) - (symbol-function 'gethash) 'cl-not-hash-table)) -(defvar cl-builtin-remhash - (if (and (fboundp 'remhash) (subrp (symbol-function 'remhash))) - (symbol-function 'remhash) 'cl-not-hash-table)) -(defvar cl-builtin-clrhash - (if (and (fboundp 'clrhash) (subrp (symbol-function 'clrhash))) - (symbol-function 'clrhash) 'cl-not-hash-table)) -(defvar cl-builtin-maphash - (if (and (fboundp 'maphash) (subrp (symbol-function 'maphash))) - (symbol-function 'maphash) 'cl-not-hash-table)) - -(defun cl-gethash (key table &optional def) - "Look up KEY in HASH-TABLE; return corresponding value, or DEFAULT." - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (if (car found) (cdr (car found)) def)) - (funcall cl-builtin-gethash key table def))) -(defalias 'gethash 'cl-gethash) - -(defun cl-puthash (key val table) - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (if (car found) (setcdr (car found) val) - (if (nth 2 found) - (progn - (if (> (nth 3 table) (* (length (nth 2 table)) 3)) - (let ((new-table (make-vector (nth 3 table) 0))) - (mapatoms (function - (lambda (sym) - (set (intern (symbol-name sym) new-table) - (symbol-value sym)))) - (nth 2 table)) - (setcar (cdr (cdr table)) new-table))) - (set (intern (nth 2 found) (nth 2 table)) - (cons (cons key val) (nth 1 found)))) - (set (nth 2 table) (cons (cons key val) (nth 1 found)))) - (setcar (cdr (cdr (cdr table))) (1+ (nth 3 table))))) - (funcall 'puthash key val table)) val) - -(defun cl-remhash (key table) - "Remove KEY from HASH-TABLE." - (if (consp table) - (let ((found (cl-hash-lookup key table))) - (and (car found) - (let ((del (delq (car found) (nth 1 found)))) - (setcar (cdr (cdr (cdr table))) (1- (nth 3 table))) - (if (nth 2 found) (set (intern (nth 2 found) (nth 2 table)) del) - (set (nth 2 table) del)) t))) - (prog1 (not (eq (funcall cl-builtin-gethash key table '--cl--) '--cl--)) - (funcall cl-builtin-remhash key table)))) -(defalias 'remhash 'cl-remhash) - -(defun cl-clrhash (table) - "Clear HASH-TABLE." - (if (consp table) - (progn - (or (hash-table-p table) (cl-not-hash-table table)) - (if (symbolp (nth 2 table)) (set (nth 2 table) nil) - (setcar (cdr (cdr table)) (make-vector (length (nth 2 table)) 0))) - (setcar (cdr (cdr (cdr table))) 0)) - (funcall cl-builtin-clrhash table)) - nil) -(defalias 'clrhash 'cl-clrhash) - -(defun cl-maphash (cl-func cl-table) - "Call FUNCTION on keys and values from HASH-TABLE." - (or (hash-table-p cl-table) (cl-not-hash-table cl-table)) - (if (consp cl-table) - (mapatoms (function (lambda (cl-x) - (setq cl-x (symbol-value cl-x)) - (while cl-x - (funcall cl-func (car (car cl-x)) - (cdr (car cl-x))) - (setq cl-x (cdr cl-x))))) - (if (symbolp (nth 2 cl-table)) - (vector (nth 2 cl-table)) (nth 2 cl-table))) - (funcall cl-builtin-maphash cl-func cl-table))) -(defalias 'maphash 'cl-maphash) - -(defun hash-table-count (table) - "Return the number of entries in HASH-TABLE." - (or (hash-table-p table) (cl-not-hash-table table)) - (if (consp table) (nth 3 table) (funcall 'hashtable-fullness table))) - +;; The `regular' Common Lisp hash-table stuff has been moved into C. +;; Only backward compatibility stuff remains here. +(defun make-hashtable (size &optional test) + (make-hash-table :size size :test test :type 'non-weak)) +(defun make-weak-hashtable (size &optional test) + (make-hash-table :size size :test test :type 'weak)) +(defun make-key-weak-hashtable (size &optional test) + (make-hash-table :size size :test test :type 'key-weak)) +(defun make-value-weak-hashtable (size &optional test) + (make-hash-table :size size :test test :type 'value-weak)) + +(define-obsolete-function-alias 'hashtablep 'hash-table-p) +(define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) +(define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) +(define-obsolete-function-alias 'hashtable-type 'hash-table-type) +(define-obsolete-function-alias 'hashtable-size 'hash-table-size) +(define-obsolete-function-alias 'copy-hashtable 'copy-hash-table) + +(make-obsolete 'make-hashtable 'make-hash-table) +(make-obsolete 'make-weak-hashtable 'make-hash-table) +(make-obsolete 'make-key-weak-hashtable 'make-hash-table) +(make-obsolete 'make-value-weak-hashtable 'make-hash-table) + +(when (fboundp 'x-keysym-hash-table) + (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) + +;; Compatibility stuff for old kludgy cl.el hash table implementation +(defvar cl-builtin-gethash (symbol-function 'gethash)) +(defvar cl-builtin-remhash (symbol-function 'remhash)) +(defvar cl-builtin-clrhash (symbol-function 'clrhash)) +(defvar cl-builtin-maphash (symbol-function 'maphash)) + +(defalias 'cl-gethash 'gethash) +(defalias 'cl-puthash 'puthash) +(defalias 'cl-remhash 'remhash) +(defalias 'cl-clrhash 'clrhash) +(defalias 'cl-maphash 'maphash) ;;; Some debugging aids. diff --git a/lisp/cl-macs.el b/lisp/cl-macs.el index 93971ff..b35f74f 100644 --- a/lisp/cl-macs.el +++ b/lisp/cl-macs.el @@ -78,9 +78,9 @@ (or (fboundp 'defalias) (fset 'defalias 'fset)) (or (fboundp 'cl-transform-function-property) (defalias 'cl-transform-function-property - (function (lambda (n p f) - (list 'put (list 'quote n) (list 'quote p) - (list 'function (cons 'lambda f))))))) + #'(lambda (n p f) + (list 'put (list 'quote n) (list 'quote p) + (list 'function (cons 'lambda f)))))) (car (or features (setq features (list 'cl-kludge)))))) @@ -97,12 +97,11 @@ (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form)) (or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler? (defalias 'byte-compile-file-form - (function - (lambda (form) - (setq form (macroexpand form byte-compile-macro-environment)) - (if (eq (car-safe form) 'progn) - (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) - (funcall cl-old-bc-file-form form)))))) + #'(lambda (form) + (setq form (macroexpand form byte-compile-macro-environment)) + (if (eq (car-safe form) 'progn) + (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) + (funcall cl-old-bc-file-form form))))) (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) (run-hooks 'cl-hack-bytecomp-hook)) @@ -455,27 +454,26 @@ Key values are compared by `eql'." (body (cons 'cond (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) - (or (eq c last-clause) - (error - "`%s' is allowed only as the last case clause" - (car c))) - t) - ((eq (car c) 'ecase-error-flag) - (list 'error "ecase failed: %s, %s" - temp (list 'quote (reverse head-list)))) - ((listp (car c)) - (setq head-list (append (car c) head-list)) - (list 'member* temp (list 'quote (car c)))) - (t - (if (memq (car c) head-list) - (error "Duplicate key in case: %s" - (car c))) - (cl-push (car c) head-list) - (list 'eql temp (list 'quote (car c))))) - (or (cdr c) '(nil))))) + #'(lambda (c) + (cons (cond ((memq (car c) '(t otherwise)) + (or (eq c last-clause) + (error + "`%s' is allowed only as the last case clause" + (car c))) + t) + ((eq (car c) 'ecase-error-flag) + (list 'error "ecase failed: %s, %s" + temp (list 'quote (reverse head-list)))) + ((listp (car c)) + (setq head-list (append (car c) head-list)) + (list 'member* temp (list 'quote (car c)))) + (t + (if (memq (car c) head-list) + (error "Duplicate key in case: %s" + (car c))) + (cl-push (car c) head-list) + (list 'eql temp (list 'quote (car c))))) + (or (cdr c) '(nil)))) clauses)))) (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) @@ -507,16 +505,15 @@ final clause, and matches if no other keys match." (body (cons 'cond (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'ecase-error-flag) - (list 'error "etypecase failed: %s, %s" - temp (list 'quote (reverse type-list)))) - (t - (cl-push (car c) type-list) - (cl-make-type-test temp (car c)))) - (or (cdr c) '(nil))))) + #'(lambda (c) + (cons (cond ((eq (car c) 'otherwise) t) + ((eq (car c) 'ecase-error-flag) + (list 'error "etypecase failed: %s, %s" + temp (list 'quote (reverse type-list)))) + (t + (cl-push (car c) type-list) + (cl-make-type-test temp (car c)))) + (or (cdr c) '(nil)))) clauses)))) (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) @@ -1165,16 +1162,14 @@ Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)" (defun cl-expand-do-loop (steps endtest body star) (list 'block nil (list* (if star 'let* 'let) - (mapcar (function (lambda (c) - (if (consp c) (list (car c) (nth 1 c)) c))) + (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) steps) (list* 'while (list 'not (car endtest)) (append body (let ((sets (mapcar - (function - (lambda (c) - (and (consp c) (cdr (cdr c)) - (list (car c) (nth 2 c))))) + #'(lambda (c) + (and (consp c) (cdr (cdr c)) + (list (car c) (nth 2 c)))) steps))) (setq sets (delq nil sets)) (and sets @@ -1264,20 +1259,19 @@ function definitions in place, then the definitions are undone (the FUNCs go back to their previous definitions, or lack thereof)." (list* 'letf* (mapcar - (function - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) cl-macro-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func (list 'function* - (list 'lambda (cadr x) - (list* 'block (car x) (cddr x)))))) - (if (and (cl-compiling-file) - (boundp 'byte-compile-function-environment)) - (cl-push (cons (car x) (eval func)) - byte-compile-function-environment)) - (list (list 'symbol-function (list 'quote (car x))) func)))) + #'(lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) cl-macro-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func (list 'function* + (list 'lambda (cadr x) + (list* 'block (car x) (cddr x)))))) + (if (and (cl-compiling-file) + (boundp 'byte-compile-function-environment)) + (cl-push (cons (car x) (eval func)) + byte-compile-function-environment)) + (list (list 'symbol-function (list 'quote (car x))) func))) bindings) body)) @@ -1285,7 +1279,7 @@ go back to their previous definitions, or lack thereof)." (defmacro labels (bindings &rest body) "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully complaint with the Common Lisp standard." +Unlike `flet', this macro is fully compliant with the Common Lisp standard." (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings (let ((var (gensym))) @@ -1337,39 +1331,36 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)." The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp." (let* ((cl-closure-vars cl-closure-vars) - (vars (mapcar (function - (lambda (x) - (or (consp x) (setq x (list x))) - (cl-push (gensym (format "--%s--" (car x))) - cl-closure-vars) - (list (car x) (cadr x) (car cl-closure-vars)))) + (vars (mapcar #'(lambda (x) + (or (consp x) (setq x (list x))) + (cl-push (gensym (format "--%s--" (car x))) + cl-closure-vars) + (list (car x) (cadr x) (car cl-closure-vars))) bindings)) - (ebody + (ebody (cl-macroexpand-all (cons 'progn body) - (nconc (mapcar (function (lambda (x) - (list (symbol-name (car x)) - (list 'symbol-value (caddr x)) - t))) vars) + (nconc (mapcar #'(lambda (x) + (list (symbol-name (car x)) + (list 'symbol-value (caddr x)) + t)) + vars) (list '(defun . cl-defun-expander)) cl-macro-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) (cadr x)))) vars) - (sublis (mapcar (function (lambda (x) - (cons (caddr x) - (list 'quote (caddr x))))) + (list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars) + (sublis (mapcar #'(lambda (x) + (cons (caddr x) (list 'quote (caddr x)))) vars) ebody)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) - (list 'make-symbol - (format "--%s--" (car x)))))) + (list 'let (mapcar #'(lambda (x) + (list (caddr x) + (list 'make-symbol + (format "--%s--" (car x))))) vars) (apply 'append '(setf) - (mapcar (function - (lambda (x) - (list (list 'symbol-value (caddr x)) (cadr x)))) + (mapcar #'(lambda (x) + (list (list 'symbol-value (caddr x)) (cadr x))) vars)) ebody)))) @@ -1403,9 +1394,8 @@ simulate true multiple return values. For compatibility, (values A B C) is a synonym for (list A B C)." (let ((temp (gensym)) (n -1)) (list* 'let* (cons (list temp form) - (mapcar (function - (lambda (v) - (list v (list 'nth (setq n (1+ n)) temp)))) + (mapcar #'(lambda (v) + (list v (list 'nth (setq n (1+ n)) temp))) vars)) body))) @@ -1422,14 +1412,15 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)." (let* ((temp (gensym)) (n 0)) (list 'let (list (list temp form)) (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp)) - (cons 'setq (apply 'nconc - (mapcar (function - (lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp)))) - vars))))))))) + (cons 'setq + (apply 'nconc + (mapcar + #'(lambda (v) + (list v (list + 'nth + (setq n (1+ n)) + temp))) + vars))))))))) ;;; Declarations. @@ -1448,7 +1439,7 @@ values. For compatibility, (values A B C) is a synonym for (list A B C)." (if (boundp 'byte-compile-bound-variables) (setq byte-compile-bound-variables ;; todo: this should compute correct binding bits vs. 0 - (append (mapcar #'(lambda (v) (cons v 0)) + (append (mapcar #'(lambda (v) (cons v 0)) (cdr spec)) byte-compile-bound-variables)))) @@ -1604,15 +1595,16 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." call))))) ;;; Some standard place types from Common Lisp. +(eval-when-compile (defvar ignored-arg)) ; Warning suppression (defsetf aref aset) (defsetf car setcar) (defsetf cdr setcdr) (defsetf elt (seq n) (store) (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) (list 'aset seq n store))) -(defsetf get (x y &optional d) (store) (list 'put x y store)) -(defsetf get* (x y &optional d) (store) (list 'put x y store)) -(defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) +(defsetf get (x y &optional ignored-arg) (store) (list 'put x y store)) +(defsetf get* (x y &optional ignored-arg) (store) (list 'put x y store)) +(defsetf gethash (x h &optional ignored-arg) (store) (list 'cl-puthash x store h)) (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) (defsetf subseq (seq start &optional end) (new) (list 'progn (list 'replace seq new ':start1 start ':end1 end) new)) @@ -1653,7 +1645,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (defsetf documentation-property put) (defsetf extent-face set-extent-face) (defsetf extent-priority set-extent-priority) -(defsetf extent-property (x y &optional d) (arg) +(defsetf extent-property (x y &optional ignored-arg) (arg) (list 'set-extent-property x y arg)) (defsetf extent-end-position (ext) (store) (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) @@ -1673,7 +1665,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-properties (&optional f) (p) `(progn (set-frame-properties ,f ,p) ,p)) -(defsetf frame-property (f p &optional d) (v) +(defsetf frame-property (f p &optional ignored-arg) (v) `(progn (set-frame-property ,f ,v) ,p)) (defsetf frame-width (&optional f) (v) `(progn (set-frame-width ,f ,v) ,v)) @@ -1708,9 +1700,9 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." ;; Misc (defsetf recent-keys-ring-size set-recent-keys-ring-size) -(defsetf symbol-value-in-buffer (s b &optional u) (store) +(defsetf symbol-value-in-buffer (s b &optional ignored-arg) (store) `(with-current-buffer ,b (set ,s ,store))) -(defsetf symbol-value-in-console (s c &optional u) (store) +(defsetf symbol-value-in-console (s c &optional ignored-arg) (store) `(letf (((selected-console) ,c)) (set ,s ,store))) @@ -1744,7 +1736,7 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (defsetf marker-insertion-type set-marker-insertion-type) (defsetf mouse-pixel-position (&optional d) (v) `(progn - set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v)) + (set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v))) ,v)) (defsetf trunc-stack-length set-trunc-stack-length) (defsetf trunc-stack-stack set-trunc-stack-stack) @@ -1791,13 +1783,13 @@ Example: (defsetf nth (n x) (v) (list 'setcar (list 'nthcdr n x) v))." (defsetf window-buffer set-window-buffer t) (defsetf window-display-table set-window-display-table t) (defsetf window-dedicated-p set-window-dedicated-p t) -(defsetf window-height () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) +(defsetf window-height (&optional window) (store) + `(progn (enlarge-window (- ,store (window-height)) nil ,window) ,store)) (defsetf window-hscroll set-window-hscroll) (defsetf window-point set-window-point) (defsetf window-start set-window-start) -(defsetf window-width () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) +(defsetf window-width (&optional window) (store) + `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store)) (defsetf x-get-cutbuffer x-store-cutbuffer t) (defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. (defsetf x-get-secondary-selection x-own-secondary-selection t) @@ -2080,8 +2072,8 @@ As a special case, if `(PLACE)' is used instead of `(PLACE VALUE)', the PLACE is not modified before executing BODY." (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) (list* 'let bindings body) - (let ((lets nil) (sets nil) - (unsets nil) (rev (reverse bindings))) + (let ((lets nil) + (rev (reverse bindings))) (while rev (let* ((place (if (symbolp (caar rev)) (list 'symbol-value (list 'quote (caar rev))) @@ -2204,8 +2196,6 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) - ;; XEmacs change - (include-tag-symbol nil) (side-eff nil) (type nil) (named nil) @@ -2215,7 +2205,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (cl-push (list 'put (list 'quote name) '(quote structure-documentation) (cl-pop descs)) forms)) (setq descs (cons '(cl-tag-slot) - (mapcar (function (lambda (x) (if (consp x) x (list x)))) + (mapcar #'(lambda (x) (if (consp x) x (list x))) descs))) (while opts (let ((opt (if (consp (car opts)) (caar opts) (car opts))) @@ -2234,13 +2224,9 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (if args (setq predicate (car args)))) ((eq opt ':include) (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)) - ;; XEmacs change - include-tag-symbol (intern (format "cl-struct-%s-tags" - include)))) + include-descs (mapcar #'(lambda (x) + (if (consp x) x (list x))) + (cdr args)))) ((eq opt ':print-function) (setq print-func (car args))) ((eq opt ':type) @@ -2370,7 +2356,7 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (let* ((name (caar constrs)) (args (cadr (cl-pop constrs))) (anames (cl-arglist-args args)) - (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) + (make (mapcar* #'(lambda (s d) (if (memq s anames) s d)) slots defaults))) (cl-push (list 'defsubst* name (list* '&cl-defs (list 'quote (cons nil descs)) args) @@ -2394,10 +2380,10 @@ copier, a `NAME-p' predicate, and setf-able `NAME-SLOT' accessors." (list 'quote include)) (list 'put (list 'quote name) '(quote cl-struct-print) print-auto) - (mapcar (function (lambda (x) - (list 'put (list 'quote (car x)) - '(quote side-effect-free) - (list 'quote (cdr x))))) + (mapcar #'(lambda (x) + (list 'put (list 'quote (car x)) + '(quote side-effect-free) + (list 'quote (cdr x)))) side-eff)) forms) (cons 'progn (nreverse (cons (list 'quote name) forms))))) @@ -2464,7 +2450,7 @@ The type name can then be used in `typecase', `check-type', etc." (list '<= val (caddr type))))))) ((memq (car-safe type) '(and or not)) (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) + (mapcar #'(lambda (x) (cl-make-type-test val x)) (cdr type)))) ((memq (car-safe type) '(member member*)) (list 'and (list 'member* val (list 'quote (cdr type))) t)) @@ -2501,10 +2487,10 @@ omitted, a default message listing FORM itself is used." (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar - (function - (lambda (x) - (and (not (cl-const-expr-p x)) - x))) (cdr form)))))) + #'(lambda (x) + (and (not (cl-const-expr-p x)) + x)) + (cdr form)))))) (list 'progn (list 'or form (if string @@ -2517,8 +2503,13 @@ omitted, a default message listing FORM itself is used." (defmacro ignore-errors (&rest body) "Execute FORMS; if an error occurs, return nil. Otherwise, return result of last FORM." - (list 'condition-case nil (cons 'progn body) '(error nil))) + `(condition-case nil (progn ,@body) (error nil))) +;;;###autoload +(defmacro ignore-file-errors (&rest body) + "Execute FORMS; if an error of type `file-error' occurs, return nil. +Otherwise, return result of last FORM." + `(condition-case nil (progn ,@body) (file-error nil))) ;;; Some predicates for analyzing Lisp forms. These are used by various ;;; macro expanders to optimize the results in certain common cases. @@ -2672,12 +2663,11 @@ surrounded by (block NAME ...)." (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole (if (cl-simple-exprs-p argvs) (setq simple t)) (let ((lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv)))) + (mapcar* #'(lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (setq body (subst argv argn body)) + (and unsafe (list argn argv))) + (list argn argv))) argns argvs)))) (if lets (list 'let lets body) body)))) @@ -2769,45 +2759,49 @@ surrounded by (block NAME ...)." form)) -(mapcar (function - (lambda (y) - (put (car y) 'side-effect-free t) - (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) - (put (car y) 'cl-compiler-macro - (list 'lambda '(w x) - (if (symbolp (cadr y)) - (list 'list (list 'quote (cadr y)) - (list 'list (list 'quote (caddr y)) 'x)) - (cons 'list (cdr y))))))) - '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) - (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) - (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) - (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) - (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) - (caaar car caar) (caadr car cadr) (cadar car cdar) - (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) - (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) - (caaadr car caadr) (caadar car cadar) (caaddr car caddr) - (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) - (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) - (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) - (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr) )) +(mapc + #'(lambda (y) + (put (car y) 'side-effect-free t) + (put (car y) 'byte-compile 'cl-byte-compile-compiler-macro) + (put (car y) 'cl-compiler-macro + (list 'lambda '(w x) + (if (symbolp (cadr y)) + (list 'list (list 'quote (cadr y)) + (list 'list (list 'quote (caddr y)) 'x)) + (cons 'list (cdr y)))))) + '((first 'car x) (second 'cadr x) (third 'caddr x) (fourth 'cadddr x) + (fifth 'nth 4 x) (sixth 'nth 5 x) (seventh 'nth 6 x) + (eighth 'nth 7 x) (ninth 'nth 8 x) (tenth 'nth 9 x) + (rest 'cdr x) (endp 'null x) (plusp '> x 0) (minusp '< x 0) + (caar car car) (cadr car cdr) (cdar cdr car) (cddr cdr cdr) + (caaar car caar) (caadr car cadr) (cadar car cdar) + (caddr car cddr) (cdaar cdr caar) (cdadr cdr cadr) + (cddar cdr cdar) (cdddr cdr cddr) (caaaar car caaar) + (caaadr car caadr) (caadar car cadar) (caaddr car caddr) + (cadaar car cdaar) (cadadr car cdadr) (caddar car cddar) + (cadddr car cdddr) (cdaaar cdr caaar) (cdaadr cdr caadr) + (cdadar cdr cadar) (cdaddr cdr caddr) (cddaar cdr cdaar) + (cddadr cdr cdadr) (cdddar cdr cddar) (cddddr cdr cdddr))) ;;; Things that are inline. (proclaim '(inline floatp-safe acons map concatenate notany notevery ;; XEmacs change - cl-set-elt revappend nreconc)) - -;;; Things that are side-effect-free. -(mapcar (function (lambda (x) (put x 'side-effect-free t))) - '(oddp evenp abs expt signum last butlast ldiff pairlis gcd lcm - isqrt floor* ceiling* truncate* round* mod* rem* subseq - list-length get* getf gethash hash-table-count)) - -;;; Things that are side-effect-and-error-free. -(mapcar (function (lambda (x) (put x 'side-effect-free 'error-free))) - '(eql floatp-safe list* subst acons equalp random-state-p - copy-tree sublis hash-table-p)) + cl-set-elt revappend nreconc + plusp minusp oddp evenp + )) + +;;; Things that are side-effect-free. Moved to byte-optimize.el +;(dolist (fun '(oddp evenp plusp minusp +; abs expt signum last butlast ldiff +; pairlis gcd lcm +; isqrt floor* ceiling* truncate* round* mod* rem* subseq +; list-length get* getf)) +; (put fun 'side-effect-free t)) + +;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el +;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p +; copy-tree sublis)) +; (put fun 'side-effect-free 'error-free)) (run-hooks 'cl-macs-load-hook) diff --git a/lisp/cl.el b/lisp/cl.el index 233a476..41a5955 100644 --- a/lisp/cl.el +++ b/lisp/cl.el @@ -183,7 +183,7 @@ Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." (if (symbolp place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) + `(car (prog1 ,place (setq ,place (cdr ,place)))) (cl-do-pop place))) (defmacro push (x place) @@ -191,7 +191,7 @@ PLACE may be a symbol, or any generalized variable allowed by `setf'." Analogous to (setf PLACE (cons X PLACE)), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (symbolp place) (list 'setq place (list 'cons x place)) + (if (symbolp place) `(setq ,place (cons ,x ,place)) (list 'callf2 'cons x place))) (defmacro pushnew (x place &rest keys) @@ -225,20 +225,9 @@ Keywords supported: :test :test-not :key" ;;; Control structures. -;; These macros are so simple and so often-used that it's better to have -;; them all the time than to load them from cl-macs.el. - -;; NOTE: these macros were moved to subr.el in FSF 20. It is of no -;; consequence to XEmacs, because we preload this file, and they -;; should better remain here. - -(defmacro when (cond &rest body) - "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." - (list 'if cond (cons 'progn body))) - -(defmacro unless (cond &rest body) - "(unless COND BODY...): if COND yields nil, do BODY, else return nil." - (cons 'if (cons cond (cons nil body)))) +;; The macros `when' and `unless' are so useful that we want them to +;; ALWAYS be available. So they've been moved from cl.el to eval.c. +;; Note: FSF Emacs moved them to subr.el in FSF 20. (defun cl-map-extents (&rest cl-args) ;; XEmacs: This used to check for overlays first, but that's wrong @@ -406,6 +395,9 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp ;;; List functions. +;; These functions are made known to the byte-compiler by cl-macs.el +;; and turned into efficient car and cdr bytecodes. + (defalias 'first 'car) (defalias 'rest 'cdr) (defalias 'endp 'null) @@ -558,30 +550,35 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp "Return the `cdr' of the `cdr' of the `cdr' of the `cdr' of X." (cdr (cdr (cdr (cdr x))))) -(defun last (x &optional n) - "Return the last link in the list LIST. -With optional argument N, return Nth-to-last link (default 1)." - (if n - (let ((m 0) (p x)) - (while (consp p) (incf m) (pop p)) - (if (<= n 0) p - (if (< n m) (nthcdr (- m n) x) x))) - (while (consp (cdr x)) (pop x)) - x)) - -(defun butlast (x &optional n) - "Return a copy of LIST with the last N elements removed." - (if (and n (<= n 0)) x - (nbutlast (copy-sequence x) n))) - -(defun nbutlast (x &optional n) - "Modify LIST to remove the last N elements." - (let ((m (length x))) - (or n (setq n 1)) - (and (< n m) - (progn - (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) - x)))) +;;; `last' is implemented as a C primitive, as of 1998-11 + +;(defun last (x &optional n) +; "Return the last link in the list LIST. +;With optional argument N, return Nth-to-last link (default 1)." +; (if n +; (let ((m 0) (p x)) +; (while (consp p) (incf m) (pop p)) +; (if (<= n 0) p +; (if (< n m) (nthcdr (- m n) x) x))) +; (while (consp (cdr x)) (pop x)) +; x)) + +;;; `butlast' is implemented as a C primitive, as of 1998-11 +;;; `nbutlast' is implemented as a C primitive, as of 1998-11 + +;(defun butlast (x &optional n) +; "Return a copy of LIST with the last N elements removed." +; (if (and n (<= n 0)) x +; (nbutlast (copy-sequence x) n))) + +;(defun nbutlast (x &optional n) +; "Modify LIST to remove the last N elements." +; (let ((m (length x))) +; (or n (setq n 1)) +; (and (< n m) +; (progn +; (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) +; x)))) (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el "Return a new list with specified args as elements, cons'd to last arg. @@ -602,14 +599,16 @@ Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to (push (pop list) res)) (nreverse res))) -(defun copy-list (list) - "Return a copy of a list, which may be a dotted list. -The elements of the list are not copied, just the list structure itself." - (if (consp list) - (let ((res nil)) - (while (consp list) (push (pop list) res)) - (prog1 (nreverse res) (setcdr res list))) - (car list))) +;;; `copy-list' is implemented as a C primitive, as of 1998-11 + +;(defun copy-list (list) +; "Return a copy of a list, which may be a dotted list. +;The elements of the list are not copied, just the list structure itself." +; (if (consp list) +; (let ((res nil)) +; (while (consp list) (push (pop list) res)) +; (prog1 (nreverse res) (setcdr res list))) +; (car list))) (defun cl-maclisp-member (item list) (while (and list (not (equal item (car list)))) (setq list (cdr list))) @@ -681,45 +680,45 @@ FUNC is not added if it already appears on the list stored in HOOK." ;(load "cl-defs") ;;; Define data for indentation and edebug. -(mapcar (function - (lambda (entry) - (mapcar (function - (lambda (func) - (put func 'lisp-indent-function (nth 1 entry)) - (put func 'lisp-indent-hook (nth 1 entry)) - (or (get func 'edebug-form-spec) - (put func 'edebug-form-spec (nth 2 entry))))) - (car entry)))) - '(((defun* defmacro*) defun) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &rest form)) - ((when unless) 1 (&rest form)) - ((declare) nil (&rest sexp)) - ((the) 1 (sexp &rest form)) - ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) - ((block return-from) 1 (sexp &rest form)) - ((return) nil (&optional form)) - ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) - (form &rest form) - &rest form)) - ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) - ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) - ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) - ((psetq setf psetf) nil edebug-setq-form) - ((progv) 2 (&rest form)) - ((flet labels macrolet) 1 - ((&rest (sexp sexp &rest form)) &rest form)) - ((symbol-macrolet lexical-let lexical-let*) 1 - ((&rest &or symbolp (symbolp form)) &rest form)) - ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) - ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) - ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) - ((letf letf*) 1 ((&rest (&rest form)) &rest form)) - ((callf destructuring-bind) 2 (sexp form &rest form)) - ((callf2) 3 (sexp form form &rest form)) - ((loop) defun (&rest &or symbolp form)) - ((ignore-errors) 0 (&rest form)))) +(mapc + #'(lambda (entry) + (mapc + #'(lambda (func) + (put func 'lisp-indent-function (nth 1 entry)) + (put func 'lisp-indent-hook (nth 1 entry)) + (or (get func 'edebug-form-spec) + (put func 'edebug-form-spec (nth 2 entry)))) + (car entry))) + '(((defun* defmacro*) defun) + ((function*) nil + (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) + ((eval-when) 1 (sexp &rest form)) + ((when unless) 1 (&rest form)) + ((declare) nil (&rest sexp)) + ((the) 1 (sexp &rest form)) + ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) + ((block return-from) 1 (sexp &rest form)) + ((return) nil (&optional form)) + ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) + (form &rest form) + &rest form)) + ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) + ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) + ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) + ((psetq setf psetf) nil edebug-setq-form) + ((progv) 2 (&rest form)) + ((flet labels macrolet) 1 + ((&rest (sexp sexp &rest form)) &rest form)) + ((symbol-macrolet lexical-let lexical-let*) 1 + ((&rest &or symbolp (symbolp form)) &rest form)) + ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) + ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) + ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) + ((letf letf*) 1 ((&rest (&rest form)) &rest form)) + ((callf destructuring-bind) 2 (sexp form &rest form)) + ((callf2) 3 (sexp form form &rest form)) + ((loop) defun (&rest &or symbolp form)) + ((ignore-errors) 0 (&rest form)))) ;;; This goes here so that cl-macs can find it if it loads right now. diff --git a/lisp/cmdloop.el b/lisp/cmdloop.el index 53fd00b..e5b4be0 100644 --- a/lisp/cmdloop.el +++ b/lisp/cmdloop.el @@ -433,9 +433,9 @@ and can edit it until it has been confirmed." (while (stringp ans) (setq ans (downcase (read-string p nil t))) ;no history (cond ((string-equal ans (gettext "yes")) - (setq ans 't)) + (setq ans t)) ((string-equal ans (gettext "no")) - (setq ans 'nil)) + (setq ans nil)) (t (ding nil 'yes-or-no-p) (discard-input) diff --git a/lisp/code-files.el b/lisp/code-files.el index 3ff114b..accbc0d 100644 --- a/lisp/code-files.el +++ b/lisp/code-files.el @@ -57,20 +57,14 @@ global environment specification.") 'buffer-file-coding-system-for-read) (defvar file-coding-system-alist - '(("\\.elc$" . (binary . binary)) -;; This must not be neccessary, slb suggests -kkm + `( +;; This must not be necessary, slb suggests -kkm ;; ("loaddefs.el$" . (binary . binary)) - ("\\.tar$" . (binary . binary)) - ("\\.\\(tif\\|tiff\\)$" . (binary . binary)) - ("\\.png$" . (binary . binary)) - ("\\.gif$" . (binary . binary)) - ("\\.\\(jpeg\\|jpg\\)$" . (binary . binary)) - ("TUTORIAL\\.hr$" . iso-8859-2) - ("TUTORIAL\\.pl$" . iso-8859-2) - ("TUTORIAL\\.ro$" . iso-8859-2) + ,@(mapcar + #'(lambda (regexp) (cons regexp 'binary)) binary-file-regexps) + ("TUTORIAL\\.\\(?:hr\\|pl\\|ro\\)\\'" . iso-8859-2) ;; ("\\.\\(el\\|emacs\\|info\\(-[0-9]+\\)?\\|texi\\)$" . iso-2022-8) ;; ("\\(ChangeLog\\|CHANGES-beta\\)$" . iso-2022-8) - ("\\.\\(gz\\|Z\\)$" . binary) ("/spool/mail/.*$" . convert-mbox-coding-system)) "Alist to decide a coding system to use for a file I/O operation. The format is ((PATTERN . VAL) ...), @@ -106,7 +100,7 @@ the current value of `buffer-file-coding-system'." "Set EOL type of buffer-file-coding-system of the current buffer to something other than what it is at the moment." (interactive) - (let ((eol-type + (let ((eol-type (coding-system-eol-type buffer-file-coding-system))) (setq buffer-file-coding-system (subsidiary-coding-system @@ -153,7 +147,7 @@ object (the entry specified a coding system)." (let ((alist file-coding-system-alist) (found nil) (codesys nil)) - (let ((case-fold-search (eq system-type 'vax-vms))) + (let ((case-fold-search nil)) (setq filename (file-name-sans-versions filename)) (while (and (not found) alist) (if (string-match (car (car alist)) filename) @@ -179,7 +173,7 @@ object (the entry specified a coding system)." (let ((alist file-coding-system-alist) (found nil) (codesys nil)) - (let ((case-fold-search (eq system-type 'vax-vms))) + (let ((case-fold-search nil)) (setq filename (file-name-sans-versions filename)) (while (and (not found) alist) (if (string-match (car (car alist)) filename) @@ -396,7 +390,7 @@ for reading. See also `insert-file-contents-access-hook', `insert-file-contents-pre-hook', `insert-file-contents-error-hook', and `insert-file-contents-post-hook'." - (let (return-val coding-system used-codesys conversion-func) + (let (return-val coding-system used-codesys) ;; OK, first load the file. (condition-case err (progn diff --git a/lisp/code-process.el b/lisp/code-process.el index 7174f97..d96ecea 100644 --- a/lisp/code-process.el +++ b/lisp/code-process.el @@ -30,6 +30,10 @@ ;;; Code: +(eval-when-compile + (defvar buffer-file-type) + (defvar binary-process-output)) + (defvar process-coding-system-alist nil "Alist to decide a coding system to use for a process I/O operation. The format is ((PATTERN . VAL) ...), @@ -66,7 +70,7 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you (let (ret) (catch 'found (let ((alist process-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search nil)) (while alist (if (string-match (car (car alist)) program) (throw 'found (setq ret (cdr (car alist)))) @@ -106,25 +110,16 @@ Otherwise waits for PROGRAM to terminate and returns a numeric exit status or a signal description string. If you quit, the process is first killed with SIGINT, then with SIGKILL if you quit again before the process exits." - (let ((temp (cond ((eq system-type 'vax-vms) - (make-temp-name "tmp:emacs")) - ((or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "em"))) - (t - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "emacs")))))) + (let ((temp + (make-temp-name + (concat (file-name-as-directory (temp-directory)) + (if (memq system-type '(ms-dos windows-nt)) "em" "emacs"))))) (unwind-protect (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist process-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search nil)) (while alist (if (string-match (car (car alist)) program) (throw 'found (setq ret (cdr (car alist))))) @@ -142,16 +137,13 @@ you quit again before the process exits." (or coding-system-for-read cs-r)) (coding-system-for-write (or coding-system-for-write cs-w))) - (if (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (if (memq system-type '(ms-dos windows-nt)) (let ((buffer-file-type binary-process-output)) (write-region start end temp nil 'silent)) (write-region start end temp nil 'silent)) (if deletep (delete-region start end)) (apply #'call-process program temp buffer displayp args))) - (condition-case () - (delete-file temp) - (file-error nil))))) + (ignore-file-errors (delete-file temp))))) (defun start-process (name buffer program &rest program-args) "Start a program in a subprocess. Return the process object for it. @@ -170,7 +162,7 @@ INCODE and OUTCODE specify the coding-system objects used in input/output (let (ret) (catch 'found (let ((alist process-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search nil)) (while alist (if (string-match (car (car alist)) program) (throw 'found (setq ret (cdr (car alist))))) @@ -224,7 +216,7 @@ Fourth arg SERVICE is name of the service desired, or an integer (let (ret) (catch 'found (let ((alist network-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms)) + (case-fold-search nil) pattern) (while alist (setq pattern (car (car alist))) diff --git a/lisp/config.el b/lisp/config.el index 67d8f8c..6952081 100644 --- a/lisp/config.el +++ b/lisp/config.el @@ -33,13 +33,13 @@ "File containing configuration parameters and their values.") (defvar config-value-hash-table nil - "Hashtable to store configuration parameters and their values.") + "Hash table to store configuration parameters and their values.") ;;;###autoload (defun config-value-hash-table () - "Return hashtable of configuration parameters and their values." + "Return hash table of configuration parameters and their values." (when (null config-value-hash-table) - (setq config-value-hash-table (make-hashtable 300)) + (setq config-value-hash-table (make-hash-table :size 300)) (save-excursion (let ((buf (get-buffer-create " *Config*"))) (set-buffer buf) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 7a573fe..f7ebcea 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -39,7 +39,7 @@ ;; very slow in an average XEmacs because of the large number of ;; symbols requiring a large number of funcalls -- XEmacs with Gnus ;; can grow to some 17000 symbols without ever doing anything fancy. -;; It would probably pay off to make a hashtable of symbols known to +;; It would probably pay off to make a hash table of symbols known to ;; Custom, similar to custom-group-hash-table. ;; This is not top priority, because none of the functions that do @@ -282,7 +282,7 @@ (defun custom-split-regexp-maybe (regexp) "If REGEXP is a string, split it to a list at `\\|'. You can get the original back with from the result with: - (mapconcat 'identity result \"\\|\") + (mapconcat #'identity result \"\\|\") IF REGEXP is not a string, return it unchanged." (if (stringp regexp) diff --git a/lisp/custom.el b/lisp/custom.el index 5b53d63..77dd59d 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -284,8 +284,7 @@ Read the section about customization in the Emacs Lisp manual for more information." `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) -;; This is preloaded very early, so we avoid using CL features. -(defvar custom-group-hash-table (make-hashtable 300 'eq) +(defvar custom-group-hash-table (make-hash-table :size 300 :test 'eq) "Hash-table of non-empty groups.") (defun custom-add-to-group (group option widget) diff --git a/lisp/derived.el b/lisp/derived.el index 9210fd8..a2c6a5c 100644 --- a/lisp/derived.el +++ b/lisp/derived.el @@ -146,35 +146,35 @@ been generated automatically, with a reference to the keymap." (setq docstring nil))) (setq docstring (or docstring (derived-mode-make-docstring parent child))) - (` (progn - (derived-mode-init-mode-variables (quote (, child))) - (defun (, child) () - (, docstring) + `(progn + (derived-mode-init-mode-variables (quote ,child)) + (defun ,child () + ,docstring (interactive) ; Run the parent. - ((, parent)) + (,parent) ; Identify special modes. - (if (get (quote (, parent)) 'special) - (put (quote (, child)) 'special t)) + (if (get (quote ,parent) 'special) + (put (quote ,child) 'special t)) ;; XEmacs addition - (let ((mode-class (get (quote (, parent)) 'mode-class))) + (let ((mode-class (get (quote ,parent) 'mode-class))) (if mode-class - (put (quote (, child)) 'mode-class mode-class))) + (put (quote ,child) 'mode-class mode-class))) ; Identify the child mode. - (setq major-mode (quote (, child))) - (setq mode-name (, name)) + (setq major-mode (quote ,child)) + (setq mode-name ,name) ; Set up maps and tables. - (derived-mode-set-keymap (quote (, child))) - (derived-mode-set-syntax-table (quote (, child))) - (derived-mode-set-abbrev-table (quote (, child))) + (derived-mode-set-keymap (quote ,child)) + (derived-mode-set-syntax-table (quote ,child)) + (derived-mode-set-abbrev-table (quote ,child)) ; Splice in the body (if any). - (,@ body) + ,@body ;;; ; Run the setup function, if ;;; ; any -- this will soon be ;;; ; obsolete. -;;; (derived-mode-run-setup-function (quote (, child))) +;;; (derived-mode-run-setup-function (quote ,child)) ; Run the hooks, if any. - (derived-mode-run-hooks (quote (, child))))))) + (derived-mode-run-hooks (quote ,child))))) ;; PUBLIC: find the ultimate class of a derived mode. @@ -223,30 +223,30 @@ the first time the mode is used." (if (boundp (derived-mode-map-name mode)) t - (eval (` (defvar (, (derived-mode-map-name mode)) - ;; XEmacs change - (make-sparse-keymap (derived-mode-map-name mode)) - (, (format "Keymap for %s." mode))))) + (eval `(defvar ,(derived-mode-map-name mode) + ;; XEmacs change + (make-sparse-keymap (derived-mode-map-name mode)) + ,(format "Keymap for %s." mode))) (put (derived-mode-map-name mode) 'derived-mode-unmerged t)) (if (boundp (derived-mode-syntax-table-name mode)) t - (eval (` (defvar (, (derived-mode-syntax-table-name mode)) - ;; XEmacs change - ;; Make a syntax table which doesn't specify anything - ;; for any char. Valid data will be merged in by - ;; derived-mode-merge-syntax-tables. - ;; (make-char-table 'syntax-table nil) - (make-syntax-table) - (, (format "Syntax table for %s." mode))))) + (eval `(defvar ,(derived-mode-syntax-table-name mode) + ;; XEmacs change + ;; Make a syntax table which doesn't specify anything + ;; for any char. Valid data will be merged in by + ;; derived-mode-merge-syntax-tables. + ;; (make-char-table 'syntax-table nil) + (make-syntax-table) + ,(format "Syntax table for %s." mode))) (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t)) (if (boundp (derived-mode-abbrev-table-name mode)) t - (eval (` (defvar (, (derived-mode-abbrev-table-name mode)) - (progn (define-abbrev-table (derived-mode-abbrev-table-name mode) nil) - (make-abbrev-table)) - (, (format "Abbrev table for %s." mode))))))) + (eval `(defvar ,(derived-mode-abbrev-table-name mode) + (progn (define-abbrev-table (derived-mode-abbrev-table-name mode) nil) + (make-abbrev-table)) + ,(format "Abbrev table for %s." mode))))) (defun derived-mode-make-docstring (parent child) "Construct a docstring for a new mode if none is provided." diff --git a/lisp/disass.el b/lisp/disass.el index 2185d19..9992f07 100644 --- a/lisp/disass.el +++ b/lisp/disass.el @@ -39,18 +39,12 @@ ;;; Code: -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-opt.el. -;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-optimize.el. (require 'byte-optimize) (defvar disassemble-column-1-indent 8 "*") (defvar disassemble-column-2-indent 10 "*") (defvar disassemble-recursive-indent 3 "*") - ;;;###autoload (defun disassemble (object &optional buffer indent interactive-p) "Print disassembled code for OBJECT in (optional) BUFFER. @@ -75,8 +69,8 @@ redefine OBJECT if it is a symbol." (defun disassemble-internal (obj indent interactive-p) - (let ((macro 'nil) - (name 'nil) + (let ((macro nil) + (name nil) args) (while (symbolp obj) (setq name obj @@ -169,8 +163,8 @@ redefine OBJECT if it is a symbol." (defun disassemble-1 (obj indent) - "Prints the byte-code call OBJ in the current buffer. -OBJ should be a call to BYTE-CODE generated by the byte compiler." + "Print the byte-code call OBJ in the current buffer. +OBJ should be a compiled-function object generated by the byte compiler." (let (bytes constvec) (if (consp obj) (setq bytes (car (cdr obj)) ; the byte code @@ -254,10 +248,10 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(...)\n") (mapcar ;recurse on list of byte-code objects - '(lambda (obj) - (disassemble-1 - obj - (+ indent disassemble-recursive-indent))) + #'(lambda (obj) + (disassemble-1 + obj + (+ indent disassemble-recursive-indent))) arg)) (t ;; really just a constant diff --git a/lisp/dragdrop.el b/lisp/dragdrop.el index 92d3069..9c46f55 100644 --- a/lisp/dragdrop.el +++ b/lisp/dragdrop.el @@ -51,7 +51,7 @@ text is inserted." (defcustom dragdrop-autoload-tm-view nil "*{EXPERIMENTAL} If non-nil, autoload tm-view to decode MIME data. -Otherwise, the buffer is only decoded if tm-view is already avaiable." +Otherwise, the buffer is only decoded if tm-view is already available." :type 'boolean :group 'drag-n-drop) @@ -176,7 +176,7 @@ Returns t if one of drop-funs returns t. Otherwise returns nil." (and (or (eq (cadr flist) t) (= (cadr flist) button)) (or (eq (caddr flist) t) - (dragdrop-compare-mods (caddr flist) modifiers)) + (dragdrop-compare-mods (caddr flist) mods)) (apply (car flist) `(,event ,object ,@(cdddr flist))) ;; (funcall (car flist) event object) (throw 'dragdrop-drop-is-done t)) @@ -356,7 +356,7 @@ format." This function uses special data types if the low-level protocol requires it. It does so by calling dragdrop-drag-pure-text." - (dragdrop-drag-pure-text event + (experimental-dragdrop-drag-pure-text event (buffer-substring-no-properties begin end))) (defun experimental-dragdrop-drag-pure-text (event text) diff --git a/lisp/easymenu.el b/lisp/easymenu.el index 9678183..906b51d 100644 --- a/lisp/easymenu.el +++ b/lisp/easymenu.el @@ -148,9 +148,9 @@ A menu item can be a list. It is treated as a submenu. The first element should be the submenu name. That's used as the menu item in the top-level menu. The cdr of the submenu list is a list of menu items, as above." - (` (progn - (defvar (, symbol) nil (, doc)) - (easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) + `(progn + (defvar ,symbol nil ,doc) + (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) (defun easy-menu-do-define (symbol maps doc menu) (if (featurep 'menubar) diff --git a/lisp/etags.el b/lisp/etags.el index 08d26b5..f00f8fa 100644 --- a/lisp/etags.el +++ b/lisp/etags.el @@ -1064,7 +1064,7 @@ See documentation of variable `tag-table-alist'." ;; Sample uses of find-tag-hook and find-tag-default-hook -;; This is wrong. We should either make this behaviour default and +;; This is wrong. We should either make this behavior default and ;; back it up, or not use it at all. For now, I've commented it out. ;; --hniksic diff --git a/lisp/files.el b/lisp/files.el index ff3f585..fd4585a 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -76,8 +76,7 @@ and FROM the name it is linked to." (regexp :tag "To"))) :group 'find-file) -;;; Turn off backup files on VMS since it has version numbers. -(defcustom make-backup-files (not (eq system-type 'vax-vms)) +(defcustom make-backup-files t "*Non-nil means make a backup of a file the first time it is saved. This can be done by renaming the file or by copying. @@ -414,8 +413,7 @@ of the same functionality is available as `split-path', which see." "Change current directory to given absolute file name DIR." ;; Put the name into directory syntax now, ;; because otherwise expand-file-name may give some bad results. - (if (not (eq system-type 'vax-vms)) - (setq dir (file-name-as-directory dir))) + (setq dir (file-name-as-directory dir)) ;; XEmacs change: stig@hackvan.com (if find-file-use-truenames (setq dir (file-truename dir))) @@ -813,8 +811,7 @@ If optional argument HACK-HOMEDIR is non-nil, then this also substitutes ;; If the home dir is just /, don't change it. (not (and (= (match-end 0) 1) ;#### unix-specific (= (aref filename 0) ?/))) - (not (and (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (not (and (memq system-type '(ms-dos windows-nt)) (save-match-data (string-match "^[a-zA-Z]:/$" filename))))) (setq filename @@ -825,11 +822,7 @@ If optional argument HACK-HOMEDIR is non-nil, then this also substitutes filename))) (defcustom find-file-not-true-dirname-list nil - "*List of logical names for which visiting shouldn't save the true dirname. -On VMS, when you visit a file using a logical name that searches a path, -you may or may not want the visited file name to record the specific -directory where the file was found. If you *do not* want that, add the logical -name to this list as a string." + "*List of logical names for which visiting shouldn't save the true dirname." :type '(repeat (string :tag "Name")) :group 'find-file) @@ -1004,15 +997,6 @@ If RAWFILE is non-nil, the file is read literally." (unless buffer-file-truename (setq buffer-file-truename truename)) (setq buffer-file-number number) - ;; On VMS, we may want to remember which directory in - ;; a search list the file was found in. - (and (eq system-type 'vax-vms) - (let (logical) - (if (string-match ":" (file-name-directory filename)) - (setq logical (substring (file-name-directory filename) - 0 (match-beginning 0)))) - (not (member logical find-file-not-true-dirname-list))) - (setq buffer-file-name buffer-file-truename)) (and find-file-use-truenames ;; This should be in C. Put pathname ;; abbreviations that have been explicitly @@ -1149,49 +1133,48 @@ run `normal-mode' explicitly." '(("\\.te?xt\\'" . text-mode) ("\\.[ch]\\'" . c-mode) ("\\.el\\'" . emacs-lisp-mode) - ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode) + ("\\.\\(?:[CH]\\|cc\\|hh\\)\\'" . c++-mode) ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode) ("\\.java\\'" . java-mode) ("\\.idl\\'" . idl-mode) - ("\\.f\\(or\\)?\\'" . fortran-mode) - ("\\.F\\(OR\\)?\\'" . fortran-mode) + ("\\.f\\(?:or\\)?\\'" . fortran-mode) + ("\\.F\\(?:OR\\)?\\'" . fortran-mode) ("\\.[fF]90\\'" . f90-mode) ;;; Less common extensions come here ;;; so more common ones above are found faster. ("\\.\\([pP][Llm]\\|al\\)\\'" . perl-mode) ("\\.py\\'" . python-mode) - ("\\.texi\\(nfo\\)?\\'" . texinfo-mode) + ("\\.texi\\(?:nfo\\)?\\'" . texinfo-mode) ("\\.ad[abs]\\'" . ada-mode) - ("\\.c?l\\(i?sp\\)?\\'" . lisp-mode) - ("\\.p\\(as\\)?\\'" . pascal-mode) + ("\\.c?l\\(?:i?sp\\)?\\'" . lisp-mode) + ("\\.p\\(?:as\\)?\\'" . pascal-mode) ("\\.ltx\\'" . latex-mode) ("\\.[sS]\\'" . asm-mode) - ("[Cc]hange.?[Ll]og?\\(.[0-9]+\\)?\\'" . change-log-mode) + ("[Cc]hange.?[Ll]og?\\(?:.[0-9]+\\)?\\'" . change-log-mode) ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) ("\\.scm?\\(?:\\.[0-9]*\\)?\\'" . scheme-mode) ("\\.e\\'" . eiffel-mode) ("\\.mss\\'" . scribe-mode) - ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode) + ("\\.m\\(?:[mes]\\|an\\)\\'" . nroff-mode) ("\\.icn\\'" . icon-mode) - ("\\.\\([ckz]?sh\\|shar\\)\\'" . sh-mode) + ("\\.\\(?:[ckz]?sh\\|shar\\)\\'" . sh-mode) ;; #### Unix-specific! - ("/\\.\\(bash_\\|z\\)?\\(profile\\|login\||logout\\)\\'" . sh-mode) - ("/\\.\\([ckz]sh\\|bash\\|tcsh\\|es\\|xinit\\|startx\\)rc\\'" . sh-mode) - ("/\\.\\([kz]shenv\\|xsession\\)\\'" . sh-mode) + ("/\\.\\(?:bash_\\|z\\)?\\(profile\\|login\||logout\\)\\'" . sh-mode) + ("/\\.\\(?:[ckz]sh\\|bash\\|tcsh\\|es\\|xinit\\|startx\\)rc\\'" . sh-mode) + ("/\\.\\(?:[kz]shenv\\|xsession\\)\\'" . sh-mode) ;; The following come after the ChangeLog pattern for the sake of ;; ChangeLog.1, etc. and after the .scm.[0-9] pattern too. ("\\.[12345678]\\'" . nroff-mode) ("\\.[tT]e[xX]\\'" . tex-mode) - ("\\.\\(sty\\|cls\\|bbl\\)\\'" . latex-mode) + ("\\.\\(?:sty\\|cls\\|bbl\\)\\'" . latex-mode) ("\\.bib\\'" . bibtex-mode) ("\\.article\\'" . text-mode) ("\\.letter\\'" . text-mode) - ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode) + ("\\.\\(?:tcl\\|exp\\)\\'" . tcl-mode) ("\\.wrl\\'" . vrml-mode) ("\\.awk\\'" . awk-mode) ("\\.prolog\\'" . prolog-mode) - ("\\.tar\\'" . tar-mode) - ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) + ("\\.\\(?:arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) ;; Mailer puts message to be edited in /tmp/Re.... or Message ;; #### Unix-specific! ("\\`/tmp/Re" . text-mode) @@ -1205,7 +1188,7 @@ run `normal-mode' explicitly." ("\\.oak\\'" . scheme-mode) ("\\.s?html?\\'" . html-mode) ("\\.htm?l?3\\'" . html3-mode) - ("\\.\\(sgml?\\|dtd\\)\\'" . sgml-mode) + ("\\.\\(?:sgml?\\|dtd\\)\\'" . sgml-mode) ("\\.c?ps\\'" . postscript-mode) ;; .emacs following a directory delimiter in either Unix or ;; Windows syntax. @@ -1218,11 +1201,8 @@ run `normal-mode' explicitly." ("\\.X\\(defaults\\|environment\\|resources\\|modmap\\)\\'" . xrdb-mode) ;; #### The following three are Unix-specific (but do we care?) ("/app-defaults/" . xrdb-mode) - ("\\.[^/]*wm\\'" . winmgr-mode) - ("\\.[^/]*wm2?rc" . winmgr-mode) - ("\\.[Jj][Pp][Ee]?[Gg]\\'" . image-mode) - ("\\.[Pp][Nn][Gg]\\'" . image-mode) - ("\\.[Gg][Ii][Ff]\\'" . image-mode) + ("\\.[^/]*wm2?\\(?:rc\\)?\\'" . winmgr-mode) + ("\\.\\(?:jpe?g\\|JPE?G\\|png\\|PNG\\|gif\\|GIF\\|tiff?\\|TIFF?\\)\\'" . image-mode) ) "Alist of filename patterns vs. corresponding major mode functions. Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL). @@ -1258,8 +1238,31 @@ The car of each element is a regular expression which is compared with the name of the interpreter specified in the first line. If it matches, mode MODE is selected.") -(defvar inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'" "\\.tgz\\'" - "\\.tar\\.gz\\'")) +(defvar binary-file-regexps + (purecopy + '("\\.\\(?:bz2\\|elc\\|g\\(if\\|z\\)\\|jp\\(eg\\|g\\)\\|png\\|t\\(ar\\|gz\\|iff\\)\\|[Zo]\\)\\'")) + "List of regexps of filenames containing binary (non-text) data.") + +; (eval-when-compile +; (require 'regexp-opt) +; (list +; (format "\\.\\(?:%s\\)\\'" +; (regexp-opt +; '("tar" +; "tgz" +; "gz" +; "bz2" +; "Z" +; "o" +; "elc" +; "png" +; "gif" +; "tiff" +; "jpg" +; "jpeg")))))) + +(defvar inhibit-first-line-modes-regexps + (purecopy binary-file-regexps) "List of regexps; if one matches a file name, don't look for `-*-'.") (defvar inhibit-first-line-modes-suffixes nil @@ -1309,7 +1312,7 @@ and we don't even do that unless it would come from the file name." (mode nil)) ;; Find first matching alist entry. (let ((case-fold-search - (memq system-type '(vax-vms windows-nt)))) + (memq system-type '(windows-nt)))) (while (and (not mode) alist) (if (string-match (car (car alist)) name) (if (and (consp (cdr (car alist))) @@ -1722,8 +1725,6 @@ the old visited file has been renamed to the new name FILENAME." (let ((new-name (file-name-nondirectory buffer-file-name))) (if (string= new-name "") (error "Empty file name")) - (if (eq system-type 'vax-vms) - (setq new-name (downcase new-name))) (setq default-directory (file-name-directory buffer-file-name)) (or (string= new-name (buffer-name)) (rename-buffer new-name t)))) @@ -1917,9 +1918,7 @@ of the new file to agree with the old modes." ;; Now delete the old versions, if desired. (if delete-old-versions (while targets - (condition-case () - (delete-file (car targets)) - (file-error nil)) + (ignore-file-errors (delete-file (car targets))) (setq targets (cdr targets)))) setmodes) (file-error nil))))))))) @@ -1934,28 +1933,17 @@ we do not remove backup version numbers, only true file version numbers." (if handler (funcall handler 'file-name-sans-versions name keep-backup-version) (substring name 0 - (if (eq system-type 'vax-vms) - ;; VMS version number is (a) semicolon, optional - ;; sign, zero or more digits or (b) period, option - ;; sign, zero or more digits, provided this is the - ;; second period encountered outside of the - ;; device/directory part of the file name. - (or (string-match ";[-+]?[0-9]*\\'" name) - (if (string-match "\\.[^]>:]*\\(\\.[-+]?[0-9]*\\)\\'" - name) - (match-beginning 1)) - (length name)) - (if keep-backup-version - (length name) - (or (string-match "\\.~[0-9.]+~\\'" name) - ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~" - (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name))) - (and pos - ;; #### - is this filesystem check too paranoid? - (file-exists-p (substring name 0 pos)) - pos)) - (string-match "~\\'" name) - (length name)))))))) + (if keep-backup-version + (length name) + (or (string-match "\\.~[0-9.]+~\\'" name) + ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~" + (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name))) + (and pos + ;; #### - is this filesystem check too paranoid? + (file-exists-p (substring name 0 pos)) + pos)) + (string-match "~\\'" name) + (length name))))))) (defun file-ownership-preserved-p (file) "Return t if deleting FILE and rewriting it would preserve the owner." @@ -2030,8 +2018,6 @@ the index in the name where the version number begins." (string-to-int (substring fn bv-length -1)) 0)) -;; I believe there is no need to alter this behavior for VMS; -;; since backup files are not made on VMS, it should not get called. (defun find-backup-file-name (fn) "Find a file name for a backup file, and suggestions for deletions. Value is a list whose car is the name for the backup file @@ -2096,8 +2082,7 @@ then it returns FILENAME." (expand-file-name (or directory default-directory)))) ;; On Microsoft OSes, if FILENAME and DIRECTORY have different ;; drive names, they can't be relative, so return the absolute name. - (if (and (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (if (and (memq system-type '(ms-dos windows-nt)) (not (string-equal (substring fname 0 2) (substring directory 0 2)))) filename @@ -2167,9 +2152,7 @@ since the last real save, but optional arg FORCE non-nil means delete anyway." (not (string= buffer-file-name buffer-auto-save-file-name)) (or force (recent-auto-save-p)) (progn - (condition-case () - (delete-file buffer-auto-save-file-name) - (file-error nil)) + (ignore-file-errors (delete-file buffer-auto-save-file-name)) (set-buffer-auto-saved)))) ;; XEmacs change (from Sun) @@ -2211,19 +2194,6 @@ After saving the buffer, run `after-save-hook'." (set-buffer (buffer-base-buffer))) (if (buffer-modified-p) (let ((recent-save (recent-auto-save-p))) - ;; On VMS, rename file and buffer to get rid of version number. - (if (and (eq system-type 'vax-vms) - (not (string= buffer-file-name - (file-name-sans-versions buffer-file-name)))) - (let (buffer-new-name) - ;; Strip VMS version number before save. - (setq buffer-file-name - (file-name-sans-versions buffer-file-name)) - ;; Construct a (unique) buffer name to correspond. - (let ((buf (create-file-buffer (downcase buffer-file-name)))) - (setq buffer-new-name (buffer-name buf)) - (kill-buffer buf)) - (rename-buffer buffer-new-name))) ;; If buffer has no file name, ask user for one. (or buffer-file-name (let ((filename @@ -2782,12 +2752,11 @@ non-nil, it is called instead of rereading visited file contents." (not (file-exists-p file-name))) (error "Auto-save file %s not current" file-name)) ((save-window-excursion - (if (not (eq system-type 'vax-vms)) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (call-process "ls" nil standard-output nil - (if (file-symlink-p file) "-lL" "-l") - file file-name))) + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (call-process "ls" nil standard-output nil + (if (file-symlink-p file) "-lL" "-l") + file file-name)) (yes-or-no-p (format "Recover auto save file %s? " file-name))) (switch-to-buffer (find-file-noselect file t)) (let ((buffer-read-only nil)) @@ -3087,16 +3056,12 @@ by `sh' are supported." ;; not its part. Make the regexp say so. (concat "\\`" result "\\'"))) -(defcustom list-directory-brief-switches - (if (eq system-type 'vax-vms) "" "-CF") +(defcustom list-directory-brief-switches "-CF" "*Switches for list-directory to pass to `ls' for brief listing." :type 'string :group 'dired) -(defcustom list-directory-verbose-switches - (if (eq system-type 'vax-vms) - "/PROTECTION/SIZE/DATE/OWNER/WIDTH=(OWNER:10)" - "-l") +(defcustom list-directory-verbose-switches "-l" "*Switches for list-directory to pass to `ls' for verbose listing," :type 'string :group 'dired) @@ -3166,8 +3131,6 @@ If WILDCARD, it also runs the shell specified by `shell-file-name'." (funcall handler 'insert-directory file switches wildcard full-directory-p) (cond - ((eq system-type 'vax-vms) - (vms-read-directory file switches (current-buffer))) ((and (fboundp 'mswindows-insert-directory) (eq system-type 'windows-nt)) (mswindows-insert-directory file switches wildcard full-directory-p)) diff --git a/lisp/fill.el b/lisp/fill.el index f76a017..780d6e6 100644 --- a/lisp/fill.el +++ b/lisp/fill.el @@ -384,6 +384,7 @@ space does not end a sentence, so don't break a line there." ;;; 97/3/14 jhod: Kinsoku change ;; Spacing is not necessary for charcters of no word-separater. ;; The regexp word-across-newline is used for this check. + (defvar word-across-newline) (if (not (and (featurep 'mule) (stringp word-across-newline))) (subst-char-in-region from (point-max) ?\n ?\ ) @@ -782,7 +783,7 @@ If the mark is not active, this applies to the current paragraph." ;; 97/3/14 jhod: This functions are added for Kinsoku support (defun find-space-insertable-point () - "Search backward for a permissable point for inserting justification spaces" + "Search backward for a permissible point for inserting justification spaces" (if (boundp 'space-insertable) (if (re-search-backward space-insertable nil t) (progn (forward-char 1) diff --git a/lisp/find-paths.el b/lisp/find-paths.el index 8ecbcc1..f5be624 100644 --- a/lisp/find-paths.el +++ b/lisp/find-paths.el @@ -66,9 +66,8 @@ from the search." (let ((raw-entries (if (equal 0 max-depth) '() - (directory-files directory nil "^[^.-]"))) + (directory-files directory nil "^[^.-]"))) (reverse-dirs '())) - (while raw-entries (if (null (string-match exclude-regexp (car raw-entries))) (setq reverse-dirs @@ -106,7 +105,7 @@ from the search." "lib" emacs-program-name))) ;; in-place or windows-nt - (and + (and (paths-file-readable-directory-p (paths-construct-path (list directory "lisp"))) (paths-file-readable-directory-p (paths-construct-path (list directory "etc")))))) @@ -153,7 +152,7 @@ to EXPAND-FILE-NAME." (defun paths-construct-emacs-directory (root suffix base) "Construct a directory name within the XEmacs hierarchy." (file-name-as-directory - (expand-file-name + (expand-file-name (concat (file-name-as-directory root) suffix @@ -236,7 +235,7 @@ If ENFORCE-VERSION is non-nil, the directory must contain the XEmacs version." (let ((reverse-directories '())) (while directories (if (paths-file-readable-directory-p (car directories)) - (setq reverse-directories + (setq reverse-directories (cons (car directories) reverse-directories))) (setq directories (cdr directories))) diff --git a/lisp/finder.el b/lisp/finder.el index 4656b32..8c9594a 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -162,47 +162,44 @@ arguments compiles from `load-path'." (insert ";;; Commentary:\n") (insert ";; Don't edit this file. It's generated by finder.el\n\n") (insert ";;; Code:\n") - (insert "\n(setq finder-package-info '(\n") + (insert "\n(defconst finder-package-info '(\n") (mapcar - (function - (lambda (d) - (mapcar - (function - (lambda (f) - (if (not (member f processed)) - (let (summary keystart keywords) - (setq processed (cons f processed)) - (if (not finder-compile-keywords-quiet) - (message "Processing %s ..." f)) - (save-excursion - (set-buffer (get-buffer-create "*finder-scratch*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-file-contents (expand-file-name f d)) - (condition-case err - (setq summary (lm-synopsis) - keywords (lm-keywords)) - (t (message "finder: error processing %s %S" f err)))) - (if (not summary) - nil - (insert (format " (\"%s\"\n " f)) - (prin1 summary (current-buffer)) - (insert "\n ") - (setq keystart (point)) - (insert (if keywords (format "(%s)" keywords) "nil")) - (subst-char-in-region keystart (point) ?, ? ) - (insert "\n ") - (prin1 (abbreviate-file-name d) (current-buffer)) - (insert ")\n")))))) - ;; - ;; Skip null, non-existent or relative pathnames, e.g. "./", if - ;; using load-path, so that they do not interfere with a scan of - ;; library directories only. - (if (and using-load-path - (not (and d (file-name-absolute-p d) (file-exists-p d)))) - nil - (setq d (file-name-as-directory (or d "."))) - (directory-files d nil "^[^=].*\\.el$"))))) + (lambda (d) + (mapcar + (lambda (f) + (when (not (member f processed)) + (let (summary keystart keywords) + (setq processed (cons f processed)) + (if (not finder-compile-keywords-quiet) + (message "Processing %s ..." f)) + (save-excursion + (set-buffer (get-buffer-create "*finder-scratch*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-file-contents (expand-file-name f d)) + (condition-case err + (setq summary (lm-synopsis) + keywords (lm-keywords)) + (t (message "finder: error processing %s %S" f err)))) + (when summary + (insert (format " (\"%s\"\n " f)) + (prin1 summary (current-buffer)) + (insert "\n ") + (setq keystart (point)) + (insert (if keywords (format "(%s)" keywords) "nil")) + (subst-char-in-region keystart (point) ?, ? ) + (insert "\n ") + (prin1 (abbreviate-file-name d) (current-buffer)) + (insert ")\n"))))) + ;; + ;; Skip null, non-existent or relative pathnames, e.g. "./", if + ;; using load-path, so that they do not interfere with a scan of + ;; library directories only. + (if (and using-load-path + (not (and d (file-name-absolute-p d) (file-exists-p d)))) + nil + (setq d (file-name-as-directory (or d "."))) + (directory-files d nil "^[^=].*\\.el$")))) dirs) (insert "))\n\n(provide 'finder-inf)\n\n;;; finder-inf.el ends here\n") (kill-buffer "*finder-scratch*") diff --git a/lisp/font-lock.el b/lisp/font-lock.el index b587a78..2918ef3 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -128,8 +128,8 @@ ;; - Keep the faces distinct from each other as far as possible. ;; i.e., (a) above. ;; - Make the face attributes fit the concept as far as possible. -;; i.e., function names might be a bold colour such as blue, comments might -;; be a bright colour such as red, character strings might be brown, because, +;; i.e., function names might be a bold color such as blue, comments might +;; be a bright color such as red, character strings might be brown, because, ;; err, strings are brown (that was not the reason, please believe me). ;; - Don't use a non-nil OVERRIDE unless you have a good reason. ;; Only use OVERRIDE for special things that are easy to define, such as the @@ -375,7 +375,7 @@ MATCH-ANCHORED should be of the form: Where MATCHER is as for MATCH-HIGHLIGHT with one exception; see below. PRE-MATCH-FORM and POST-MATCH-FORM are evaluated before the first, and after the last, instance MATCH-ANCHORED's MATCHER is used. Therefore they can be -used to initialise before, and cleanup after, MATCHER is used. Typically, +used to initialize before, and cleanup after, MATCHER is used. Typically, PRE-MATCH-FORM is used to move to some position relative to the original MATCHER, before starting with MATCH-ANCHORED's MATCHER. POST-MATCH-FORM might be used to move, before resuming with MATCH-ANCHORED's parent's MATCHER. @@ -533,8 +533,7 @@ This is normally set via `font-lock-defaults'.") :type 'boolean :initialize 'custom-initialize-default :require 'font-lock - :set '(lambda (var val) - (font-lock-mode (or val 0))) + :set #'(lambda (var val) (font-lock-mode (or val 0))) ) (defvar font-lock-fontified nil) ; whether we have hacked this buffer diff --git a/lisp/font.el b/lisp/font.el index ecaf1c9..b6baa29 100644 --- a/lisp/font.el +++ b/lisp/font.el @@ -32,6 +32,7 @@ (require 'cl) (eval-and-compile + (defvar device-fonts-cache) (condition-case () (require 'custom) (error nil)) @@ -40,8 +41,8 @@ ;; We have the old custom-library, hack around it! (defmacro defgroup (&rest args) nil) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))))) + (defmacro defcustom (var value doc &rest args) + `(defvar ,var ,value ,doc)))) (if (not (fboundp 'try-font-name)) (defun try-font-name (fontname &rest args) @@ -89,13 +90,12 @@ "Whether we are running in XEmacs or not.") (defmacro define-font-keywords (&rest keys) - (` - (eval-and-compile - (let ((keywords (quote (, keys)))) + `(eval-and-compile + (let ((keywords (quote ,keys))) (while keywords (or (boundp (car keywords)) (set (car keywords) (car keywords))) - (setq keywords (cdr keywords))))))) + (setq keywords (cdr keywords)))))) (defconst font-window-system-mappings '((x . (x-font-create-name x-font-create-object)) @@ -187,37 +187,36 @@ for use in the 'weight' field of an X font string.") (eval-when-compile (defmacro define-new-mask (attr mask) - (` - (progn + `(progn (setq font-style-keywords - (cons (cons (quote (, attr)) + (cons (cons (quote ,attr) (cons - (quote (, (intern (format "set-font-%s-p" attr)))) - (quote (, (intern (format "font-%s-p" attr)))))) + (quote ,(intern (format "set-font-%s-p" attr))) + (quote ,(intern (format "font-%s-p" attr))))) font-style-keywords)) - (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) - (, (format - "Bitmask for whether a font is to be rendered in %s or not." - attr))) - (defun (, (intern (format "font-%s-p" attr))) (fontobj) - (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) + (defconst ,(intern (format "font-%s-mask" attr)) (<< 1 ,mask) + ,(format + "Bitmask for whether a font is to be rendered in %s or not." + attr)) + (defun ,(intern (format "font-%s-p" attr)) (fontobj) + ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr) (if (/= 0 (& (font-style fontobj) - (, (intern (format "font-%s-mask" attr))))) + ,(intern (format "font-%s-mask" attr)))) t nil)) - (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val) - (, (format "Set whether FONTOBJ will be renderd in `%s' or not." - attr)) + (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val) + ,(format "Set whether FONTOBJ will be renderd in `%s' or not." + attr) (cond (val (set-font-style fontobj (| (font-style fontobj) - (, (intern - (format "font-%s-mask" attr)))))) - (((, (intern (format "font-%s-p" attr))) fontobj) + ,(intern + (format "font-%s-mask" attr))))) + ((,(intern (format "font-%s-p" attr)) fontobj) (set-font-style fontobj (- (font-style fontobj) - (, (intern - (format "font-%s-mask" attr)))))))) - )))) + ,(intern + (format "font-%s-mask" attr))))))) + ))) (let ((mask 0)) (define-new-mask bold (setq mask (1+ mask))) @@ -250,7 +249,7 @@ for use in the 'weight' field of an X font string.") (while (< i 255) ;; Oslash - Thorn (aset table i (- i 32)) (setq i (1+ i))) - table)) + table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utility functions @@ -435,15 +434,14 @@ for use in the 'weight' field of an X font string.") (make-font :size "12pt")) (defun tty-font-create-plist (fontobj &optional device) - (let ((styles (font-style fontobj)) - (weight (font-weight fontobj))) - (list - (cons 'underline (font-underline-p fontobj)) - (cons 'highlight (if (or (font-bold-p fontobj) - (memq weight '(:bold :demi-bold))) t)) - (cons 'dim (font-dim-p fontobj)) - (cons 'blinking (font-blink-p fontobj)) - (cons 'reverse (font-reverse-p fontobj))))) + (list + (cons 'underline (font-underline-p fontobj)) + (cons 'highlight (if (or (font-bold-p fontobj) + (memq (font-weight fontobj) '(:bold :demi-bold))) + t)) + (cons 'dim (font-dim-p fontobj)) + (cons 'blinking (font-blink-p fontobj)) + (cons 'reverse (font-reverse-p fontobj)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -560,16 +558,13 @@ for use in the 'weight' field of an X font string.") (set-font-italic-p retval t)) ((member slant '("o" "O")) (set-font-oblique-p retval t))) - (if (string-match font-x-registry-and-encoding-regexp fontname) - (progn - (set-font-registry retval (match-string 1 fontname)) - (set-font-encoding retval (match-string 2 fontname)))) + (when (string-match font-x-registry-and-encoding-regexp fontname) + (set-font-registry retval (match-string 1 fontname)) + (set-font-encoding retval (match-string 2 fontname))) retval)))) (defun x-font-families-for-device (&optional device no-resetp) - (condition-case () - (require 'x-font-menu) - (error nil)) + (ignore-errors (require 'x-font-menu)) (or device (setq device (selected-device))) (if (boundp 'device-fonts-cache) (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) @@ -577,9 +572,9 @@ for use in the 'weight' field of an X font string.") (progn (reset-device-font-menus device) (x-font-families-for-device device t)) - (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 0))) - (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (normal (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 1)))) (sort (font-unique (nconc scaled normal)) 'string-lessp)))) (cons "monospace" (mapcar 'car font-x-family-mappings)))) @@ -597,40 +592,32 @@ for use in the 'weight' field of an X font string.") (if (and (fboundp 'fontsetp) (fontsetp font)) (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) font)))) - + ;;;###autoload (defun font-default-object-for-device (&optional device) (let ((font (font-default-font-for-device device))) - (or (cdr-safe - (assoc font font-default-cache)) - (progn - (setq font-default-cache (cons (cons font - (font-create-object font)) - font-default-cache)) - (cdr-safe (assoc font font-default-cache)))))) + (unless (cdr-safe (assoc font font-default-cache)) + (push (cons font (font-create-object font)) font-default-cache) + (cdr-safe (assoc font font-default-cache))))) ;;;###autoload (defun font-default-family-for-device (&optional device) - (or device (setq device (selected-device))) - (font-family (font-default-object-for-device device))) + (font-family (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-registry-for-device (&optional device) - (or device (setq device (selected-device))) - (font-registry (font-default-object-for-device device))) + (font-registry (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-encoding-for-device (&optional device) - (or device (setq device (selected-device))) - (font-encoding (font-default-object-for-device device))) + (font-encoding (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-size-for-device (&optional device) - (or device (setq device (selected-device))) ;; face-height isn't the right thing (always 1 pixel too high?) ;; (if font-running-xemacs ;; (format "%dpx" (face-height 'default device)) - (font-size (font-default-object-for-device device))) + (font-size (font-default-object-for-device (or device (selected-device))))) (defun x-font-create-name (fontobj &optional device) (if (and (not (or (font-family fontobj) @@ -718,9 +705,9 @@ for use in the 'weight' field of an X font string.") (progn (reset-device-font-menus device) (ns-font-families-for-device device t)) - (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 0))) - (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (normal (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 1)))) (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) @@ -778,14 +765,14 @@ for use in the 'weight' field of an X font string.") ;;; Missing parts of the font spec should be filled in with these values: ;;; Courier New:Regular:10::western ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$" -(defvar font-mswindows-font-regexp +(defvar font-mswindows-font-regexp (let ((- ":") (fontname "\\([a-zA-Z ]+\\)") (weight "\\([a-zA-Z]*\\)") (style "\\( [a-zA-Z]*\\)?") (pointsize "\\([0-9]+\\)") - (effects "\\([a-zA-Z ]*\\)")q + (effects "\\([a-zA-Z ]*\\)") (charset "\\([a-zA-Z 0-9]*\\)") ) (concat "^" @@ -889,7 +876,7 @@ for use in the 'weight' field of an mswindows font string.") (and (font-bold-p fontobj) :bold))) (if (stringp size) (setq size (truncate (font-spatial-to-canonical size device)))) - (setq weight (or (cdr-safe + (setq weight (or (cdr-safe (assq weight mswindows-font-weight-mappings)) "")) (let ((done nil) ; Did we find a good font yet? (font-name nil) ; font name we are currently checking @@ -928,7 +915,7 @@ for use in the 'weight' field of an mswindows font string.") ;;; Cache building code ;;;###autoload (defun x-font-build-cache (&optional device) - (let ((hashtable (make-hash-table :test 'equal :size 15)) + (let ((hash-table (make-hash-table :test 'equal :size 15)) (fonts (mapcar 'x-font-create-object (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) (plist nil) @@ -936,7 +923,7 @@ for use in the 'weight' field of an mswindows font string.") (while fonts (setq cur (car fonts) fonts (cdr fonts) - plist (cl-gethash (car (font-family cur)) hashtable)) + plist (cl-gethash (car (font-family cur)) hash-table)) (if (not (memq (font-weight cur) (plist-get plist 'weights))) (setq plist (plist-put plist 'weights (cons (font-weight cur) (plist-get plist 'weights))))) @@ -949,8 +936,8 @@ for use in the 'weight' field of an mswindows font string.") (if (and (font-italic-p cur) (not (memq 'italic (plist-get plist 'styles)))) (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles))))) - (cl-puthash (car (font-family cur)) plist hashtable)) - hashtable)) + (cl-puthash (car (font-family cur)) plist hash-table)) + hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1128,7 +1115,7 @@ The list (R G B) is returned, or an error is signaled if the lookup fails." (?3 . 3) (?d . 13) (?D . 13) (?4 . 4) (?e . 14) (?E . 14) (?5 . 5) (?f . 15) (?F . 15) - (?6 . 6) + (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9))) @@ -1230,7 +1217,7 @@ The variable x-library-search-path is use to locate the rgb.txt file." ((and (vectorp color) (= 3 (length color))) (list (aref color 0) (aref color 1) (aref color 2))) ((and (listp color) (= 3 (length color)) (floatp (car color))) - (mapcar (function (lambda (x) (* x 65535))) color)) + (mapcar #'(lambda (x) (* x 65535)) color)) ((and (listp color) (= 3 (length color))) color) ((or (string-match "^#" color) @@ -1250,7 +1237,7 @@ The variable x-library-search-path is use to locate the rgb.txt file." (font-lookup-rgb-components color))))) (defsubst font-tty-compute-color-delta (col1 col2) - (+ + (+ (* (- (aref col1 0) (aref col2 0)) (- (aref col1 0) (aref col2 0))) (* (- (aref col1 1) (aref col2 1)) @@ -1307,7 +1294,7 @@ is returned." (tty (apply 'font-tty-find-closest-color (font-color-rgb-components color))) (ns - (let ((vals (mapcar (function (lambda (x) (>> x 8))) + (let ((vals (mapcar #'(lambda (x) (>> x 8)) (font-color-rgb-components color)))) (apply 'format "RGB%02x%02x%02xff" vals))) (otherwise @@ -1365,7 +1352,7 @@ is returned." (if (or (eq face face-at) (and (listp face-at) (memq face face-at))) (setq found t))) found)) - + (defun font-blink-callback () ;; Optimized to never invert the face unless one of the visible windows ;; is showing it. @@ -1383,7 +1370,7 @@ is returned." "How often to blink faces" :type 'number :group 'faces) - + (defun font-blink-initialize () (cond ((featurep 'itimer) @@ -1393,10 +1380,10 @@ is returned." font-blink-interval font-blink-interval)) ((fboundp 'run-at-time) - (cancel-function-timers 'font-blink-callback) + (cancel-function-timers 'font-blink-callback) (run-at-time font-blink-interval font-blink-interval 'font-blink-callback)) (t nil))) - + (provide 'font) diff --git a/lisp/gnuserv.el b/lisp/gnuserv.el index 7b89699..b670e8d 100644 --- a/lisp/gnuserv.el +++ b/lisp/gnuserv.el @@ -68,7 +68,7 @@ ;; ported the server-temp-file-regexp feature from server.el ;; ported server hooks from server.el ;; ported kill-*-query functions from server.el (and made it optional) -;; synced other behaviour with server.el +;; synced other behavior with server.el ;; ;; Jan Vroonhof ;; Customized. diff --git a/lisp/help.el b/lisp/help.el index 8590638..eb7b1b6 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -914,15 +914,11 @@ unless the function is autoloaded." :type 'boolean :group 'help-appearance) -(defun describe-symbol-find-file (function) - (let ((files load-history) - file) - (while files - (if (memq function (cdr (car files))) - (setq file (car (car files)) - files nil)) - (setq files (cdr files))) - file)) +(defun describe-symbol-find-file (symbol) + (loop for (file . load-data) in load-history + do (when (memq symbol load-data) + (return file)))) + (define-obsolete-function-alias 'describe-function-find-file 'describe-symbol-find-file) @@ -1378,10 +1374,6 @@ after the listing is made.)" (s (process-status p))) (setq tail (cdr tail)) (princ (format "%-13s" (process-name p))) - ;;(if (and (eq system-type 'vax-vms) - ;; (eq s 'signal) - ;; (< (process-exit-status p) NSIG)) - ;; (princ (aref sys_errlist (process-exit-status p)))) (princ s) (if (and (eq s 'exit) (/= (process-exit-status p) 0)) (princ (format " %d" (process-exit-status p)))) diff --git a/lisp/hyper-apropos.el b/lisp/hyper-apropos.el index 2839b73..699e4fc 100644 --- a/lisp/hyper-apropos.el +++ b/lisp/hyper-apropos.el @@ -211,7 +211,7 @@ This map inherits from `hyper-apropos-help-map.'") (defvar hyper-apropos-mode-hook nil "*User function run after hyper-apropos mode initialization. Usage: -\(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).") +\(add-hook 'hyper-apropos-mode-hook #'(lambda () ... your init forms ...)).") ;; ---------------------------------------------------------------------- ;; @@ -380,7 +380,7 @@ General Commands: ;; ---------------------------------------------------------------------- ;; -;; similar to `describe-key-briefly', copied from prim/help.el by CW +;; similar to `describe-key-briefly', copied from help.el by CW ;;;###autoload (defun hyper-describe-key (key) @@ -452,7 +452,7 @@ See also `hyper-apropos' and `hyper-describe-function'." (if v (format " (default %s): " v) ": ")) - (mapcar (function (lambda (x) (list (symbol-name x)))) + (mapcar #'(lambda (x) (list (symbol-name x))) (face-list)) nil t nil 'hyper-apropos-face-history))) (list (if (string= val "") @@ -885,14 +885,13 @@ See also `hyper-apropos' and `hyper-describe-function'." (progn (setq ok t) (copy-face symbol 'hyper-apropos-temp-face 'global) - (mapcar (function - (lambda (property) - (setq symtype (face-property-instance symbol - property)) - (if symtype - (set-face-property 'hyper-apropos-temp-face - property - symtype)))) + (mapcar #'(lambda (property) + (setq symtype (face-property-instance symbol + property)) + (if symtype + (set-face-property 'hyper-apropos-temp-face + property + symtype))) built-in-face-specifiers) (setq font (cons (face-property-instance symbol 'font nil 0 t) (face-property-instance symbol 'font)) diff --git a/lisp/info.el b/lisp/info.el index fdbd74c..bc245ff 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -313,6 +313,8 @@ ;; Use the new macro `with-search-caps-disable-folding' ;; Code: +(eval-when-compile + (condition-case nil (require 'browse-url) (error nil))) (defgroup info nil "The info package for Emacs." @@ -460,6 +462,7 @@ heading." (".info.gz" . "gzip -dc %s") (".info-z" . "gzip -dc %s") (".info.Z" . "uncompress -c %s") + (".bz2" . "bzip2 -dc %s") (".gz" . "gzip -dc %s") (".Z" . "uncompress -c %s") (".zip" . "unzip -c %s") ) @@ -804,12 +807,12 @@ actually get any text from." ;; Verify that none of the files we used has changed ;; since we used it. (eval (cons 'and - (mapcar '(lambda (elt) - (let ((curr (file-attributes (car elt)))) - ;; Don't compare the access time. - (if curr (setcar (nthcdr 4 curr) 0)) - (setcar (nthcdr 4 (cdr elt)) 0) - (equal (cdr elt) curr))) + (mapcar #'(lambda (elt) + (let ((curr (file-attributes (car elt)))) + ;; Don't compare the access time. + (if curr (setcar (nthcdr 4 curr) 0)) + (setcar (nthcdr 4 (cdr elt)) 0) + (equal (cdr elt) curr))) Info-dir-file-attributes)))) (insert Info-dir-contents) (let ((dirs (reverse Info-directory-list)) @@ -1022,19 +1025,19 @@ directory has been modified more recently." newer) (setq Info-dir-newer-info-files nil) (mapcar - '(lambda (f) - (prog2 - (setq f-mod-time (nth 5 (file-attributes f))) - (setq newer (or (> (car f-mod-time) (car dir-mod-time)) - (and (= (car f-mod-time) (car dir-mod-time)) - (> (car (cdr f-mod-time)) (car (cdr dir-mod-time)))))) - (if (and (file-readable-p f) - newer) - (setq Info-dir-newer-info-files - (cons f Info-dir-newer-info-files))))) + #'(lambda (f) + (prog2 + (setq f-mod-time (nth 5 (file-attributes f))) + (setq newer (or (> (car f-mod-time) (car dir-mod-time)) + (and (= (car f-mod-time) (car dir-mod-time)) + (> (car (cdr f-mod-time)) (car (cdr dir-mod-time)))))) + (if (and (file-readable-p f) + newer) + (setq Info-dir-newer-info-files + (cons f Info-dir-newer-info-files))))) (directory-files (file-name-directory file) 'fullname - ".*\\.info\\(.gz\\|.Z\\|-z\\|.zip\\)?$" + ".*\\.info\\(\\.gz\\|\\.bz2\\|\\.Z\\|-z\\|\\.zip\\)?$" 'nosort t)) Info-dir-newer-info-files)) @@ -1088,22 +1091,22 @@ and `END-INFO-DIR-ENTRY'" (let ((tab-width 8) (description-col 0) len) - (mapcar '(lambda (e) - (setq e (cdr e)) ; Drop filename - (setq len (length (concat (car e) - (car (cdr e))))) - (if (> len description-col) - (setq description-col len))) + (mapcar #'(lambda (e) + (setq e (cdr e)) ; Drop filename + (setq len (length (concat (car e) + (car (cdr e))))) + (if (> len description-col) + (setq description-col len))) entries) (setq description-col (+ 5 description-col)) - (mapcar '(lambda (e) - (setq e (cdr e)) ; Drop filename - (insert "* " (car e) ":" (car (cdr e))) - (setq e (car (cdr (cdr e)))) - (while e - (indent-to-column description-col) - (insert (car e) "\n") - (setq e (cdr e)))) + (mapcar #'(lambda (e) + (setq e (cdr e)) ; Drop filename + (insert "* " (car e) ":" (car (cdr e))) + (setq e (car (cdr (cdr e)))) + (while e + (indent-to-column description-col) + (insert (car e) "\n") + (setq e (cdr e)))) entries) (insert "\n"))) @@ -1134,15 +1137,15 @@ to the value of `Info-save-auto-generated-dir'" "Info files in " directory ":\n\n") (Info-dump-dir-entries (mapcar - '(lambda (f) - (or (Info-extract-dir-entry-from f) - (list 'dummy - (progn - (string-match "\\(.*\\)\\.info\\(.gz\\|.Z\\|-z\\|.zip\\)?$" - (file-name-nondirectory f)) - (capitalize (match-string 1 (file-name-nondirectory f)))) - ":" - (list Info-no-description-string)))) + #'(lambda (f) + (or (Info-extract-dir-entry-from f) + (list 'dummy + (progn + (string-match "\\(.*\\)\\.info\\(.gz\\|.Z\\|-z\\|.zip\\)?$" + (file-name-nondirectory f)) + (capitalize (match-string 1 (file-name-nondirectory f)))) + ":" + (list Info-no-description-string)))) info-files)) (if to-temp (set-buffer-modified-p nil) @@ -1199,33 +1202,34 @@ the value of `Info-save-auto-generated-dir' " (narrow-to-region mark next-section) (setq dir-section-contents (nreverse (Info-parse-dir-entries (point-min) (point-max)))) - (mapcar '(lambda (file) - (setq dir-entry (assoc (downcase - (file-name-sans-extension - (file-name-nondirectory file))) - dir-section-contents) - file-dir-entry (Info-extract-dir-entry-from file)) - (if dir-entry - (if file-dir-entry - ;; A dir entry in the info file takes precedence over an - ;; existing entry in the dir file - (setcdr dir-entry (cdr file-dir-entry))) - (unless (or not-first-section - (assoc (downcase + (mapcar + #'(lambda (file) + (setq dir-entry (assoc (downcase (file-name-sans-extension (file-name-nondirectory file))) - dir-full-contents)) - (if file-dir-entry - (setq dir-section-contents (cons file-dir-entry - dir-section-contents)) - (setq dir-section-contents - (cons (list 'dummy - (capitalize (file-name-sans-extension - (file-name-nondirectory file))) - ":" - (list Info-no-description-string)) - dir-section-contents)))))) - Info-dir-newer-info-files) + dir-section-contents) + file-dir-entry (Info-extract-dir-entry-from file)) + (if dir-entry + (if file-dir-entry + ;; A dir entry in the info file takes precedence over an + ;; existing entry in the dir file + (setcdr dir-entry (cdr file-dir-entry))) + (unless (or not-first-section + (assoc (downcase + (file-name-sans-extension + (file-name-nondirectory file))) + dir-full-contents)) + (if file-dir-entry + (setq dir-section-contents (cons file-dir-entry + dir-section-contents)) + (setq dir-section-contents + (cons (list 'dummy + (capitalize (file-name-sans-extension + (file-name-nondirectory file))) + ":" + (list Info-no-description-string)) + dir-section-contents)))))) + Info-dir-newer-info-files) (delete-region (point-min) (point-max)) (Info-dump-dir-entries (nreverse dir-section-contents)) (widen) @@ -1372,15 +1376,12 @@ for; usually a downcased version of NAME." (format (cdr (car suff)) file) (concat (cdr (car suff)) " < " file)))) (message "%s..." command) - (if (eq system-type 'vax-vms) - (call-process command nil t nil) - (call-process shell-file-name nil t nil "-c" command)) + (call-process shell-file-name nil t nil "-c" command) (message "") - (if visit - (progn - (setq buffer-file-name file) - (set-buffer-modified-p nil) - (clear-visited-file-modtime)))) + (when visit + (setq buffer-file-name file) + (set-buffer-modified-p nil) + (clear-visited-file-modtime))) (insert-file-contents file visit)))) (defun Info-select-node () @@ -2779,6 +2780,7 @@ e Edit the contents of the current node." ;; #### The console-on-window-system-p check is to allow this to ;; work on tty's. The real problem here is that featurep really ;; needs to have some device/console domain knowledge added to it. + (defvar info::toolbar) (if (and (featurep 'toolbar) (console-on-window-system-p) (not Info-inhibit-toolbar)) diff --git a/lisp/itimer.el b/lisp/itimer.el index 78610a9..aab95e4 100644 --- a/lisp/itimer.el +++ b/lisp/itimer.el @@ -717,8 +717,7 @@ x start a new itimer (inhibit-quit nil) ;; for FSF Emacs timer.el emulation under XEmacs. ;; eldoc expect this to be done, apparently. - (this-command nil) - itimer itimers time-elapsed) + (this-command nil)) (if (itimer-uses-arguments current-itimer) (apply (itimer-function current-itimer) (itimer-function-arguments current-itimer)) diff --git a/lisp/lib-complete.el b/lisp/lib-complete.el index 83123c6..b524c11 100644 --- a/lisp/lib-complete.el +++ b/lisp/lib-complete.el @@ -38,7 +38,7 @@ ;; Last Modified By: Heiko M|nkel ;; Additional XEmacs integration By: Chuck Thompson ;; Last Modified On: Thu Jul 1 14:23:00 1994 -;; RCS Info : $Revision: 1.3 $ $Locker: $ +;; RCS Info : $Revision: 1.3.2.1 $ $Locker: $ ;; ======================================================================== ;; NOTE: XEmacs must be redumped if this file is changed. ;; @@ -104,25 +104,24 @@ If optional fourth argument FAST is non-nil, don't sort the completions, ;;=== Utilities =========================================================== -(defmacro progn-with-message (MESSAGE &rest FORMS) +(defmacro progn-with-message (message &rest forms) "(progn-with-message MESSAGE FORMS ...) Display MESSAGE and evaluate FORMS, returning value of the last one." ;; based on Hallvard Furuseth's funcall-with-message - (` - (if (eq (selected-window) (minibuffer-window)) + `(if (eq (selected-window) (minibuffer-window)) (save-excursion (goto-char (point-max)) (let ((orig-pmax (point-max))) (unwind-protect (progn - (insert " " (, MESSAGE)) (goto-char orig-pmax) + (insert " " ,message) (goto-char orig-pmax) (sit-for 0) ; Redisplay - (,@ FORMS)) + ,@forms) (delete-region orig-pmax (point-max))))) (prog2 - (message "%s" (, MESSAGE)) - (progn (,@ FORMS)) - (message ""))))) + (message "%s" ,message) + (progn ,@forms) + (message "")))) (put 'progn-with-message 'lisp-indent-hook 1) @@ -218,6 +217,7 @@ where each has the form (if tail (setcdr tail nil))))) ;;=== Read a filename, with completion in a search path =================== +(defvar read-library-internal-search-path) (defun read-library-internal (FILE FILTER FLAG) "Don't call this." diff --git a/lisp/lisp-mnt.el b/lisp/lisp-mnt.el index f03f23e..76feeb2 100644 --- a/lisp/lisp-mnt.el +++ b/lisp/lisp-mnt.el @@ -449,17 +449,17 @@ a temporary buffer." (switch-to-buffer (get-buffer-create "*lm-verify*")) (erase-buffer) (mapcar - '(lambda (f) - (if (string-match ".*\\.el$" f) - (let ((status (lm-verify f))) - (if status - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column status "\n")) - (and showok - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column "OK\n"))))))) + #'(lambda (f) + (if (string-match ".*\\.el$" f) + (let ((status (lm-verify f))) + (if status + (progn + (insert f ":") + (lm-insert-at-column lm-comment-column status "\n")) + (and showok + (progn + (insert f ":") + (lm-insert-at-column lm-comment-column "OK\n"))))))) (directory-files file)) )) (save-excursion diff --git a/lisp/loaddefs.el b/lisp/loaddefs.el index 77ba4b1..44ab60b 100644 --- a/lisp/loaddefs.el +++ b/lisp/loaddefs.el @@ -86,15 +86,10 @@ ;; making it more likely you will get a unique match. (setq completion-ignored-extensions (mapcar 'purecopy - (if (eq system-type 'vax-vms) - '(".obj" ".elc" ".exe" ".bin" ".lbin" ".sbin" - ".dvi" ".toc" ".log" ".aux" - ".lof" ".brn" ".rnt" ".mem" ".lni" ".lis" - ".olb" ".tlb" ".mlb" ".hlb" ".glo" ".idx" ".lot" ".fmt") - '(".o" ".elc" "~" ".bin" ".lbin" ".fasl" - ".dvi" ".toc" ".log" ".aux" ".a" ".ln" - ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot" ".fmt" - ".diff" ".oi" ".class")))) + '(".o" ".elc" "~" ".bin" ".lbin" ".fasl" + ".dvi" ".toc" ".log" ".aux" ".a" ".ln" + ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot" ".fmt" + ".diff" ".oi" ".class"))) ;; This needs to be redone better. -slb diff --git a/lisp/loadhist.el b/lisp/loadhist.el index f55a51f..7783fd3 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -34,81 +34,69 @@ ;;; Code: +;; load-history is a list of entries that look like this: +;; ("outline" outline-regexp ... (require . wid-edit) ... (provide . outline) ...) + (defun symbol-file (sym) "Return the input source from which SYM was loaded. This is a file name, or nil if the source was a buffer with no associated file." (interactive "SFind source file for symbol: ") ; XEmacs - (catch 'foundit - (mapcar - (function (lambda (x) (if (memq sym (cdr x)) (throw 'foundit (car x))))) - load-history) - nil)) + (dolist (entry load-history) + (when (memq sym (cdr entry)) + (return (car entry))))) (defun feature-symbols (feature) "Return the file and list of symbols associated with a given FEATURE." - (catch 'foundit - (mapcar - (function (lambda (x) - (if (member (cons 'provide feature) (cdr x)) - (throw 'foundit x)))) - load-history) - nil)) + (let ((pair `(provide . ,feature))) + (dolist (entry load-history) + (when (member pair (cdr entry)) + (return entry))))) (defun feature-file (feature) "Return the file name from which a given FEATURE was loaded. Actually, return the load argument, if any; this is sometimes the name of a Lisp file without an extension. If the feature came from an eval-buffer on a buffer with no associated file, or an eval-region, return nil." - (if (not (featurep feature)) - (error "%s is not a currently loaded feature" (symbol-name feature)) - (car (feature-symbols feature)))) + (unless (featurep feature) + (error "%s is not a currently loaded feature" (symbol-name feature))) + (car (feature-symbols feature))) + +(defun file-symbols (file) + "Return the file and list of symbols associated with FILE. +The file name in the returned list is the string used to load the file, +and may not be the same string as FILE, but it will be equivalent." + (or (assoc file load-history) + (assoc (file-name-sans-extension file) load-history) + (assoc (concat file ".el") load-history) + (assoc (concat file ".elc") load-history))) (defun file-provides (file) "Return the list of features provided by FILE." - (let ((symbols (or (cdr (assoc file load-history)) - (cdr (assoc (file-name-sans-extension file) load-history)) - (cdr (assoc (concat file ".el") load-history)) - (cdr (assoc (concat file ".elc") load-history)))) - (provides nil)) - (mapcar - (function (lambda (x) - (if (and (consp x) (eq (car x) 'provide)) - (setq provides (cons (cdr x) provides))))) - symbols) - provides - )) + (let ((provides nil)) + (dolist (x (cdr (file-symbols file))) + (when (eq (car-safe x) 'provide) + (push (cdr x) provides))) + provides)) (defun file-requires (file) "Return the list of features required by FILE." - (let ((symbols (cdr (assoc file load-history))) (requires nil)) - (mapcar - (function (lambda (x) - (if (and (consp x) (eq (car x) 'require)) - (setq requires (cons (cdr x) requires))))) - symbols) - requires - )) - -(defun file-set-intersect (p q) - ;; Return the set intersection of two lists - (let ((ret nil)) - (mapcar - (function (lambda (x) (if (memq x q) (setq ret (cons x ret))))) - p) - ret - )) + (let ((requires nil)) + (dolist (x (cdr (file-symbols file))) + (when (eq (car-safe x) 'require) + (push (cdr x) requires))) + requires)) (defun file-dependents (file) "Return the list of loaded libraries that depend on FILE. This can include FILE itself." - (let ((provides (file-provides file)) (dependents nil)) - (mapcar - (function (lambda (x) - (if (file-set-intersect provides (file-requires (car x))) - (setq dependents (cons (car x) dependents))))) - load-history) - dependents - )) + (let ((provides (file-provides file)) + (dependents nil)) + (dolist (entry load-history) + (dolist (x (cdr entry)) + (when (and (eq (car-safe x) 'require) + (memq (cdr-safe x) provides)) + (push (car entry) dependents)))) + dependents)) ;; FSFmacs ;(defun read-feature (prompt) @@ -116,8 +104,8 @@ This can include FILE itself." ;prompting with PROMPT and completing from `features', and ;return the feature \(symbol\)." ; (intern (completing-read prompt -; (mapcar (function (lambda (feature) -; (list (symbol-name feature)))) +; (mapcar #'(lambda (feature) +; (list (symbol-name feature))) ; features) ; nil t))) @@ -127,28 +115,27 @@ This can include FILE itself." If the feature is required by any other loaded code, and optional FORCE is nil, raise an error." (interactive "SFeature: ") - (if (not (featurep feature)) - (error "%s is not a currently loaded feature" (symbol-name feature))) - (if (not force) - (let* ((file (feature-file feature)) - (dependents (delete file (copy-sequence (file-dependents file))))) - (if dependents - (error "Loaded libraries %s depend on %s" - (prin1-to-string dependents) file) - ))) + (unless (featurep feature) + (error "%s is not a currently loaded feature" (symbol-name feature))) + (when (not force) + (let* ((file (feature-file feature)) + (dependents (delete file (copy-sequence (file-dependents file))))) + (when dependents + (error "Loaded libraries %s depend on %s" + (prin1-to-string dependents) file)))) (let* ((flist (feature-symbols feature)) (file (car flist))) (mapcar - (function (lambda (x) - (cond ((stringp x) nil) - ((consp x) - ;; Remove any feature names that this file provided. - (if (eq (car x) 'provide) - (setq features (delq (cdr x) features)))) - ((boundp x) (makunbound x)) - ((fboundp x) - (fmakunbound x) - (let ((aload (get x 'autoload))) - (if aload (fset x (cons 'autoload aload)))))))) + #'(lambda (x) + (cond ((stringp x) nil) + ((consp x) + ;; Remove any feature names that this file provided. + (if (eq (car x) 'provide) + (setq features (delq (cdr x) features)))) + ((boundp x) (makunbound x)) + ((fboundp x) + (fmakunbound x) + (let ((aload (get x 'autoload))) + (if aload (fset x (cons 'autoload aload))))))) (cdr flist)) ;; Delete the load-history element for this file. (let ((elt (assoc file load-history))) diff --git a/lisp/loadup.el b/lisp/loadup.el index 35cc183..61188a9 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -34,14 +34,17 @@ ;;; Code: -(if (fboundp 'error) - (error "loadup.el already loaded!")) +(when (fboundp 'error) + (error "loadup.el already loaded!")) (defvar running-xemacs t "Non-nil when the current emacs is XEmacs.") (defvar preloaded-file-list nil "List of files preloaded into the XEmacs binary image.") + +(let ((gc-cons-threshold 30000)) + ;; This is awfully damn early to be getting an error, right? (call-with-condition-handler 'really-early-error-handler #'(lambda () @@ -79,11 +82,9 @@ ;; there will be lots of extra space in the data segment filled ;; with garbage-collected junk) (defun pureload (file) - (let ((full-path (locate-file file - load-path - (if load-ignore-elc-files - ".el:" - ".elc:.el:")))) + (let ((full-path + (locate-file file load-path + (if load-ignore-elc-files ".el:" ".elc:.el:")))) (if full-path (prog1 (load full-path) @@ -100,16 +101,14 @@ (let ((files preloaded-file-list) file) (while (setq file (car files)) - (or (pureload file) - (progn - (external-debugging-output "Fatal error during load, aborting") - (kill-emacs 1))) + (unless (pureload file) + (external-debugging-output "Fatal error during load, aborting") + (kill-emacs 1)) (setq files (cdr files))) - (if (not (featurep 'toolbar)) - (progn - ;; else still define a few functions. - (defun toolbar-button-p (obj) "No toolbar support." nil) - (defun toolbar-specifier-p (obj) "No toolbar support." nil))) + (when (not (featurep 'toolbar)) + ;; else still define a few functions. + (defun toolbar-button-p (obj) "No toolbar support." nil) + (defun toolbar-specifier-p (obj) "No toolbar support." nil)) (fmakunbound 'pureload)) (packages-load-package-dumped-lisps late-package-load-path) @@ -134,8 +133,8 @@ ;; But you must also cause them to be scanned when the DOC file ;; is generated. For VMS, you must edit ../../vms/makedoc.com. ;; For other systems, you must edit ../../src/Makefile.in.in. -(if (load "site-load" t) - (garbage-collect)) +(when (load "site-load" t) + (garbage-collect)) ;;FSFmacs randomness ;;(if (fboundp 'x-popup-menu) @@ -158,29 +157,30 @@ (message "Finding pointers to doc strings...") (Snarf-documentation "DOC") (message "Finding pointers to doc strings...done") - (Verify-documentation) - ) + (Verify-documentation)) ;; Note: You can cause additional libraries to be preloaded ;; by writing a site-init.el that loads them. ;; See also "site-load" above. -(if (stringp site-start-file) - (load "site-init" t)) +(when (stringp site-start-file) + (load "site-init" t)) (setq current-load-list nil) (garbage-collect) ;;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +) ;; frequent garbage collection + ;; Dump into the name `xemacs' (only) (when (member "dump" command-line-args) - (message "Dumping under the name xemacs") - ;; This is handled earlier in the build process. - ;; (condition-case () (delete-file "xemacs") (file-error nil)) - (when (fboundp 'really-free) - (really-free)) - (dump-emacs (if (featurep 'infodock) "infodock" "xemacs") "temacs") - (kill-emacs)) + (message "Dumping under the name xemacs") + ;; This is handled earlier in the build process. + ;; (condition-case () (delete-file "xemacs") (file-error nil)) + (when (fboundp 'really-free) + (really-free)) + (dump-emacs (if (featurep 'infodock) "infodock" "xemacs") "temacs") + (kill-emacs)) ;; Avoid error if user loads some more libraries now. (setq purify-flag nil) @@ -197,9 +197,9 @@ ;; so that the .el files always get loaded (the .elc files may be out-of- ;; date or bad). (when (member "recompile" command-line-args) - (let ((command-line-args-left (cdr (member "recompile" command-line-args)))) - (batch-byte-recompile-directory) - (kill-emacs))) + (setq command-line-args-left (cdr (member "recompile" command-line-args))) + (batch-byte-recompile-directory) + (kill-emacs)) ;; For machines with CANNOT_DUMP defined in config.h, ;; this file must be loaded each time Emacs is run. diff --git a/lisp/make-docfile.el b/lisp/make-docfile.el index 9157467..c501878 100644 --- a/lisp/make-docfile.el +++ b/lisp/make-docfile.el @@ -171,7 +171,7 @@ nil "-fc" (mapconcat - 'identity + #'identity (append (list (concat default-directory "../lib-src/make-docfile")) options processed) diff --git a/lisp/map-ynp.el b/lisp/map-ynp.el index 64d3e58..6fef0e9 100644 --- a/lisp/map-ynp.el +++ b/lisp/map-ynp.el @@ -90,15 +90,14 @@ Returns the number of actions taken." (compiled-function-p list) (and (consp list) (eq (car list) 'lambda))) - (function (lambda () - (setq elt (funcall list)))) - (function (lambda () - (if list - (progn - (setq elt (car list) - list (cdr list)) - t) - nil)))))) + #'(lambda () (setq elt (funcall list))) + #'(lambda () + (if list + (progn + (setq elt (car list) + list (cdr list)) + t) + nil))))) (if (should-use-dialog-box-p) ;; Make a list describing a dialog box. (let (;; (object (capitalize (or (nth 0 help) "object"))) @@ -123,19 +122,18 @@ Returns the number of actions taken." ("Yes All" . automatic) ("No All" . exit) ("Cancel" . quit) - ,@(mapcar (lambda (elt) - (cons (capitalize (nth 2 elt)) - (vector (nth 1 elt)))) + ,@(mapcar #'(lambda (elt) + (cons (capitalize (nth 2 elt)) + (vector (nth 1 elt)))) action-alist)) mouse-event last-command-event)) (setq user-keys (if action-alist - (concat (mapconcat (function - (lambda (elt) - (key-description - (if (characterp (car elt)) - ;; XEmacs - (char-to-string (car elt)) - (car elt))))) + (concat (mapconcat #'(lambda (elt) + (key-description + (if (characterp (car elt)) + ;; XEmacs + (char-to-string (car elt)) + (car elt)))) action-alist ", ") " ") "") @@ -156,8 +154,8 @@ Returns the number of actions taken." (unwind-protect (progn (if (stringp prompter) - (setq prompter (` (lambda (object) - (format (, prompter) object))))) + (setq prompter `(lambda (object) + (format ,prompter object)))) (while (funcall next) (setq prompt (funcall prompter elt)) (cond ((stringp prompt) @@ -186,7 +184,7 @@ Returns the number of actions taken." (single-key-description char)))) (setq def (lookup-key map (vector char)))) (cond ((eq def 'exit) - (setq next (function (lambda () nil)))) + (setq next #'(lambda () nil))) ((eq def 'act) ;; Act on the object. (funcall actor elt) @@ -201,9 +199,9 @@ Returns the number of actions taken." next (function (lambda () nil)))) ((or (eq def 'quit) (eq def 'exit-prefix)) (setq quit-flag t) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))) + (setq next `(lambda () + (setq next ',next) + ',elt))) ((eq def 'automatic) ;; Act on this and all following objects. ;; (if (funcall prompter elt) ; Emacs @@ -244,34 +242,34 @@ the current %s and exit." (set-buffer standard-output) (help-mode))) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))) + (setq next `(lambda () + (setq next ',next) + ',elt))) ((vectorp def) ;; A user-defined key. (if (funcall (aref def 0) elt) ;Call its function. ;; The function has eaten this object. (setq actions (1+ actions)) ;; Regurgitated; try again. - (setq next (` (lambda () - (setq next '(, next)) - '(, elt)))))) + (setq next `(lambda () + (setq next ',next) + ',elt)))) ;((and (consp char) ; Emacs ; (eq (car char) 'switch-frame)) ; ;; switch-frame event. Put it off until we're done. ; (setq delayed-switch-frame char) - ; (setq next (` (lambda () - ; (setq next '(, next)) - ; '(, elt))))) + ; (setq next `(lambda () + ; (setq next ',next) + ; ',elt))) (t ;; Random char. (message "Type %s for help." (key-description (vector help-char))) (beep) (sit-for 1) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))))) + (setq next `(lambda () + (setq next ',next) + ',elt))))) ((eval prompt) (progn (funcall actor elt) diff --git a/lisp/menubar.el b/lisp/menubar.el index 4ac3cf6..a2f84d5 100644 --- a/lisp/menubar.el +++ b/lisp/menubar.el @@ -171,8 +171,8 @@ See `current-menubar' for a description of the syntax of a menubar." menuitem))) ))) ) - ;; (t (signal 'error (list "unrecognised menu descriptor" menuitem)))) - (t (message "unrecognised menu descriptor %s" (prin1-to-string menuitem)))) + ;; (t (signal 'error (list "unrecognized menu descriptor" menuitem)))) + (t (message "unrecognized menu descriptor %s" (prin1-to-string menuitem)))) (setq menu (cdr menu))))) diff --git a/lisp/minibuf.el b/lisp/minibuf.el index 1217fe6..6055b8f 100644 --- a/lisp/minibuf.el +++ b/lisp/minibuf.el @@ -41,7 +41,7 @@ ;;; Code: (defgroup minibuffer nil - "Controling the behaviour of the minibuffer." + "Controling the behavior of the minibuffer." :group 'environment) @@ -350,7 +350,7 @@ If optional second arg INITIAL-CONTENTS is non-nil, it is a string to be inserted into the minibuffer before reading input. If INITIAL-CONTENTS is (STRING . POSITION), the initial input is STRING, but point is placed POSITION characters into the string. -Third arg KEYMAP is a keymap to use whilst reading; +Third arg KEYMAP is a keymap to use while reading; if omitted or nil, the default is `minibuffer-local-map'. If fourth arg READ is non-nil, then interpret the result as a lisp object and return that object: @@ -1477,24 +1477,21 @@ only existing buffer names are allowed." (olen (length string)) new n o ch) - (cond ((eq system-type 'vax-vms) - string) - ((not (string-match regexp string)) - string) - (t - (setq n 1) - (while (string-match regexp string (match-end 0)) - (setq n (1+ n))) - (setq new (make-string (+ olen n) ?$)) - (setq n 0 o 0) - (while (< o olen) - (setq ch (aref string o)) - (aset new n ch) - (setq o (1+ o) n (1+ n)) - (if (eq ch ?$) - ;; already aset by make-string initial-value - (setq n (1+ n)))) - new)))) + (if (not (string-match regexp string)) + string + (setq n 1) + (while (string-match regexp string (match-end 0)) + (setq n (1+ n))) + (setq new (make-string (+ olen n) ?$)) + (setq n 0 o 0) + (while (< o olen) + (setq ch (aref string o)) + (aset new n ch) + (setq o (1+ o) n (1+ n)) + (if (eq ch ?$) + ;; already aset by make-string initial-value + (setq n (1+ n)))) + new))) (defun read-file-name-2 (history prompt dir default must-match initial-contents @@ -1511,8 +1508,7 @@ only existing buffer names are allowed." (length dir))) (t (un-substitute-in-file-name dir)))) - (val (let ((completion-ignore-case (or completion-ignore-case - (eq system-type 'vax-vms)))) + (val ;; Hateful, broken, case-sensitive un*x ;;; (completing-read prompt ;;; completer @@ -1520,22 +1516,22 @@ only existing buffer names are allowed." ;;; must-match ;;; insert ;;; history) - ;; #### - this is essentially the guts of completing read. - ;; There should be an elegant way to pass a pair of keymaps to - ;; completing read, but this will do for now. All sins are - ;; relative. --Stig - (let ((minibuffer-completion-table completer) - (minibuffer-completion-predicate dir) - (minibuffer-completion-confirm (if (eq must-match 't) - nil t)) - (last-exact-completion nil)) - (read-from-minibuffer prompt - insert - (if (not must-match) - read-file-name-map - read-file-name-must-match-map) - nil - history))) + ;; #### - this is essentially the guts of completing read. + ;; There should be an elegant way to pass a pair of keymaps to + ;; completing read, but this will do for now. All sins are + ;; relative. --Stig + (let ((minibuffer-completion-table completer) + (minibuffer-completion-predicate dir) + (minibuffer-completion-confirm (if (eq must-match 't) + nil t)) + (last-exact-completion nil)) + (read-from-minibuffer prompt + insert + (if (not must-match) + read-file-name-map + read-file-name-must-match-map) + nil + history)) )) ;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar" ;;; (let ((hist (cond ((not history) 'minibuffer-history) @@ -1728,7 +1724,7 @@ DIR defaults to current buffer's directory default." (alist #'(lambda () (mapcar #'(lambda (x) (cons (substring x 0 (string-match "=" x)) - 'nil)) + nil)) process-environment)))) (cond ((eq action 'lambda) @@ -1743,7 +1739,7 @@ DIR defaults to current buffer's directory default." (concat "$" p) (concat head "$" p))) (all-completions env (funcall alist)))) - (t ;; 'nil + (t ;; nil ;; complete (let* ((e (funcall alist)) (val (try-completion env e))) @@ -1779,7 +1775,7 @@ DIR defaults to current buffer's directory default." ;; all completions (mapcar #'un-substitute-in-file-name (file-name-all-completions name dir))) - (t;; 'nil + (t;; nil ;; complete (let* ((d (or dir default-directory)) (val (file-name-completion name d))) @@ -1820,11 +1816,8 @@ DIR defaults to current buffer's directory default." nil 'directories)))) (mapcar fn - (cond ((eq system-type 'vax-vms) - l) - (t - ;; Wretched unix - (delete "." l)))))))) + ;; Wretched unix + (delete "." l)))))) (cond ((eq action 'lambda) ;; complete? (if (not orig) diff --git a/lisp/modeline.el b/lisp/modeline.el index 43da2ae..5311486 100644 --- a/lisp/modeline.el +++ b/lisp/modeline.el @@ -81,7 +81,7 @@ make the clicked-on window taller or shorter." (start-nwindows (count-windows t)) ;; (hscroll-delta (face-width 'modeline)) ;; (start-hscroll (modeline-hscroll (event-window event))) - (start-x-pixel (event-x-pixel event)) +; (start-x-pixel (event-x-pixel event)) (last-timestamp 0) default-line-height modeline-height @@ -220,7 +220,7 @@ make the clicked-on window taller or shorter." "Handle mouse clicks on modeline by switching buffers. If click on left half of a frame's modeline, bury current buffer. If click on right half of a frame's modeline, raise bottommost buffer. -Arg EVENT is the button release event that occured on the modeline." +Arg EVENT is the button release event that occurred on the modeline." (or (event-over-modeline-p event) (error "not over a modeline")) (or (button-release-event-p event) diff --git a/lisp/mouse.el b/lisp/mouse.el index a401d3b..7c07a20 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -68,13 +68,13 @@ text is inserted." :group 'mouse) (defcustom mouse-highlight-text 'context - "*Choose the default double-click highlighting behaviour. + "*Choose the default double-click highlighting behavior. If set to `context', double-click will highlight words when the mouse is at a word character, or a symbol if the mouse is at a symbol character. If set to `word', double-click will always attempt to highlight a word. If set to `symbol', double-click will always attempt to highlight a - symbol (the default behaviour in previous XEmacs versions)." + symbol (the default behavior in previous XEmacs versions)." :type '(choice (const context) (const word) (const symbol)) @@ -960,7 +960,7 @@ at the initial click position." ;; always sufficient but it seems to give something ;; approaching a 99% success rate. Making it higher yet ;; would help guarantee success with the price that the - ;; delay would start to become noticable. + ;; delay would start to become noticeable. ;; (and (eq (console-type) 'x) (sit-for 0.15 t)) diff --git a/lisp/obsolete.el b/lisp/obsolete.el index a205c6b..e71fa7a 100644 --- a/lisp/obsolete.el +++ b/lisp/obsolete.el @@ -346,7 +346,7 @@ Multibyte characters are concerned." ;; ### This function is not compatible with FSF in some cases. Hard ;; to fix, because it is hard to trace the logic of the FSF function. -;; In case we need the exact behaviour, we can always copy the FSF +;; In case we need the exact behavior, we can always copy the FSF ;; version, which is very long and does lots of unnecessary stuff. (defun truncate-string-to-width (str end-column &optional start-column padding) "Truncate string STR to end at column END-COLUMN. @@ -377,4 +377,5 @@ the resulting string may be narrower than END-COLUMN." (make-obsolete 'function-called-at-point 'function-at-point) +(provide 'obsolete) ;;; obsolete.el ends here diff --git a/lisp/package-admin.el b/lisp/package-admin.el index e205846..8969704 100644 --- a/lisp/package-admin.el +++ b/lisp/package-admin.el @@ -432,7 +432,8 @@ PACKAGE is a symbol, not a string." ;; Delete empty directories. (if dirs (let ( (orig-default-directory default-directory) - directory files file ) +; directory files file + ) ;; Make sure we preserve the existing `default-directory'. ;; JV, why does this change the default directory? Does it indeed? (unwind-protect diff --git a/lisp/package-get.el b/lisp/package-get.el index 383e0ff..539c6be 100644 --- a/lisp/package-get.el +++ b/lisp/package-get.el @@ -609,7 +609,6 @@ required by PACKAGES." (mapcar #'(lambda (reqd) (let* ((reqd-package (package-get-package-provider reqd)) - (reqd-version (cadr reqd-package)) (reqd-name (car reqd-package))) (if (null reqd-name) (error "Unable to find a provider for %s" reqd)) diff --git a/lisp/paragraphs.el b/lisp/paragraphs.el index 98b558b..cb6025c 100644 --- a/lisp/paragraphs.el +++ b/lisp/paragraphs.el @@ -57,7 +57,7 @@ only considered as a candidate to match `paragraph-start' or Prefix argument says to turn mode on if positive, off if negative. When the mode is turned on, if there are newlines in the buffer but no hard -newlines, ask the user whether to mark as hard any newlines preceeding a +newlines, ask the user whether to mark as hard any newlines preceding a `paragraph-start' line. From a program, second arg INSERT specifies whether to do this; it can be `never' to change nothing, t or `always' to force marking, `guess' to try to do the right thing with no questions, nil diff --git a/lisp/paths.el b/lisp/paths.el index 58266c2..5deff64 100644 --- a/lisp/paths.el +++ b/lisp/paths.el @@ -118,8 +118,7 @@ Its name should end with a slash.") (defconst remote-shell-program nil "Program used to execute shell commands on a remote machine.") -(defconst term-file-prefix - (purecopy (if (eq system-type 'vax-vms) "[.term]" "term/")) +(defconst term-file-prefix (purecopy "term/") "If non-nil, Emacs startup does (load (concat term-file-prefix (getenv \"TERM\"))) You may set this variable to nil in your `.emacs' file if you do not wish the terminal-initialization file to be loaded.") @@ -127,10 +126,7 @@ the terminal-initialization file to be loaded.") (defconst manual-program nil "Program to run to print man pages.") -(defconst abbrev-file-name - (purecopy (if (eq system-type 'vax-vms) - "~/abbrev.def" - "~/.abbrev_defs")) +(defconst abbrev-file-name (purecopy "~/.abbrev_defs") "*Default name of file to read abbrevs from.") (defconst directory-abbrev-alist diff --git a/lisp/process.el b/lisp/process.el index 1c93601..0f3f64c 100644 --- a/lisp/process.el +++ b/lisp/process.el @@ -33,6 +33,9 @@ ;;; Code: +(defvar binary-process-output) +(defvar buffer-file-type) + (defgroup processes nil "Process, subshell, compilation, and job control support." :group 'external @@ -62,14 +65,10 @@ BUFFER is the buffer or (buffer-name) to associate with the process. Third arg is command name, the name of a shell command. Remaining arguments are the arguments for the command. Wildcards and redirection are handled as usual in the shell." - (cond - ((eq system-type 'vax-vms) - (apply 'start-process name buffer args)) - ;; We used to use `exec' to replace the shell with the command, - ;; but that failed to handle (...) and semicolon, etc. - (t - (start-process name buffer shell-file-name shell-command-switch - (mapconcat 'identity args " "))))) + ;; We used to use `exec' to replace the shell with the command, + ;; but that failed to handle (...) and semicolon, etc. + (start-process name buffer shell-file-name shell-command-switch + (mapconcat #'identity args " "))) (defun call-process (program &optional infile buffer displayp &rest args) "Call PROGRAM synchronously in separate process. @@ -114,31 +113,19 @@ Otherwise waits for PROGRAM to terminate and returns a numeric exit status or a signal description string. If you quit, the process is first killed with SIGINT, then with SIGKILL if you quit again before the process exits." - (let ((temp (cond ((eq system-type 'vax-vms) - (make-temp-name "tmp:emacs")) - ((or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "em"))) - (t - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "emacs")))))) + (let ((temp + (make-temp-name + (concat (file-name-as-directory (temp-directory)) + (if (memq system-type '(ms-dos windows-nt)) "em" "emacs"))))) (unwind-protect (progn - (if (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (if (memq system-type '(ms-dos windows-nt)) (let ((buffer-file-type binary-process-output)) (write-region start end temp nil 'silent)) (write-region start end temp nil 'silent)) (if deletep (delete-region start end)) (apply #'call-process program temp buffer displayp args)) - (condition-case () - (delete-file temp) - (file-error nil))))) + (ignore-file-errors (delete-file temp))))) (defun shell-command (command &optional output-buffer) @@ -188,7 +175,7 @@ In either case, the output is inserted after point (leaving mark after it)." ;; in the buffer itself. (defun shell-command-sentinel (process signal) (if (memq (process-status process) '(exit signal)) - (message "%s: %s." + (message "%s: %s." (car (cdr (cdr (process-command process)))) (substring signal 0 -1)))) @@ -260,7 +247,7 @@ In either case, the output is inserted after point (leaving mark after it)." shell-file-name t t nil shell-command-switch command)) (setq success t)) - ;; Clear the output buffer, + ;; Clear the output buffer, ;; then run the command with output there. (save-excursion (set-buffer buffer) @@ -295,7 +282,7 @@ In either case, the output is inserted after point (leaving mark after it)." (buffer-substring (point) (progn (end-of-line) (point)))))) - (t + (t (set-window-start (display-buffer buffer) 1)))))))) diff --git a/lisp/select.el b/lisp/select.el index aebf676..824e2db 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -273,7 +273,7 @@ secondary selection instead of the primary selection." ;; why is killed-rectangle free? Is it used somewhere? ;; should it be defvarred? (setq killed-rectangle (extract-rectangle s e)) - (kill-new (mapconcat 'identity killed-rectangle "\n"))) + (kill-new (mapconcat #'identity killed-rectangle "\n"))) (copy-region-as-kill s e)) ;; Maybe killing doesn't own clipboard. Make sure it happens. ;; This memq is kind of grody, because they might have done it diff --git a/lisp/setup-paths.el b/lisp/setup-paths.el index b64dc0b..4b365ef 100644 --- a/lisp/setup-paths.el +++ b/lisp/setup-paths.el @@ -111,10 +111,12 @@ (defun paths-find-lock-directory (roots) "Find the lock directory." + (defvar configure-lock-directory) (paths-find-site-directory roots "lock" "EMACSLOCKDIR" configure-lock-directory)) (defun paths-find-superlock-file (lock-directory) "Find the superlock file." + ;; #### There is no such variable configure-superlock-file! (cond ((null lock-directory) nil) diff --git a/lisp/shadow.el b/lisp/shadow.el index f841f40..1a27d8d 100644 --- a/lisp/shadow.el +++ b/lisp/shadow.el @@ -51,7 +51,7 @@ ;; Thanks to Francesco Potorti` for suggestions, ;; rewritings & speedups. -;; 1998-08-15 Martin Buchholz: Speed up using hashtables instead of lists. +;; 1998-08-15 Martin Buchholz: Speed up using hash tables instead of lists. ;;; Code: @@ -70,12 +70,12 @@ See the documentation for `list-load-path-shadows' for further information." dir ; The dir being currently scanned. curr-files ; This dir's Emacs Lisp files. orig-dir ; Where the file was first seen. - (file-dirs - (make-hashtable 2000 'equal)) ; File names ever seen, with dirs. - (true-names - (make-hashtable 50 'equal)) ; Dirs ever considered. - (files-seen-this-dir - (make-hashtable 100 'equal)) ; Files seen so far in this dir. + (file-dirs ; File names ever seen, with dirs. + (make-hash-table :size 2000 :test 'equal)) + (true-names ; Dirs ever considered. + (make-hash-table :size 50 :test 'equal)) + (files-seen-this-dir ; Files seen so far in this dir. + (make-hash-table :size 100 :test 'equal)) ) (dolist (path-elt (or path load-path)) diff --git a/lisp/simple.el b/lisp/simple.el index 70fe279..74daf55 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -433,7 +433,7 @@ and KILLP is t if a prefix arg was specified." (and overwrite-mode (not (eolp)) (save-excursion (insert-char ?\ arg)))) -(defcustom delete-key-deletes-forward nil +(defcustom delete-key-deletes-forward t "*If non-nil, the DEL key will erase one character forwards. If nil, the DEL key will erase one character backwards." :type 'boolean @@ -2369,7 +2369,7 @@ With any other arg, set comment column to indentation of the previous comment (defun kill-comment (arg) "Kill the comment on this line, if any. With argument, kill comments on that many lines starting with this one." - ;; this function loses in a lot of situations. it incorrectly recognises + ;; this function loses in a lot of situations. it incorrectly recognizes ;; comment delimiters sometimes (ergo, inside a string), doesn't work ;; with multi-line comments, can kill extra whitespace if comment wasn't ;; through end-of-line, et cetera. diff --git a/lisp/startup.el b/lisp/startup.el index c601f84..f36d12c 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -364,13 +364,12 @@ Type ^H^H^H (Control-h Control-h Control-h) to get more help options.\n") (message "Back to top level.") (setq command-line-processed t) ;; Canonicalize HOME (PWD is canonicalized by init_buffer in buffer.c) - (unless (eq system-type 'vax-vms) - (let ((value (user-home-directory))) - (if (and value - (< (length value) (length default-directory)) - (equal (file-attributes default-directory) - (file-attributes value))) - (setq default-directory (file-name-as-directory value))))) + (let ((value (user-home-directory))) + (if (and value + (< (length value) (length default-directory)) + (equal (file-attributes default-directory) + (file-attributes value))) + (setq default-directory (file-name-as-directory value)))) (setq default-directory (abbreviate-file-name default-directory)) (initialize-xemacs-paths) diff --git a/lisp/subr.el b/lisp/subr.el index 69af79b..e1a2a29 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -88,9 +88,6 @@ Used for compatibility among different emacs variants." ;; XEmacs: not used. ;; XEmacs: -(define-function 'not 'null) -(define-function-when-void 'numberp 'integerp) ; different when floats - (defun local-variable-if-set-p (sym buffer) "Return t if SYM would be local to BUFFER after it is set. A nil value for BUFFER is *not* the same as (current-buffer), but @@ -586,12 +583,14 @@ This function accepts any number of arguments, but ignores them." (cons (cons name defs) abbrev-table-name-list))))))) -(defun functionp (object) - "Non-nil if OBJECT can be called as a function." - (or (and (symbolp object) (fboundp object)) - (subrp object) - (compiled-function-p object) - (eq (car-safe object) 'lambda))) +;;; `functionp' has been moved into C. + +;;(defun functionp (object) +;; "Non-nil if OBJECT can be called as a function." +;; (or (and (symbolp object) (fboundp object)) +;; (subrp object) +;; (compiled-function-p object) +;; (eq (car-safe object) 'lambda))) diff --git a/lisp/symbol-syntax.el b/lisp/symbol-syntax.el index 871e4fe..285498e 100644 --- a/lisp/symbol-syntax.el +++ b/lisp/symbol-syntax.el @@ -101,14 +101,12 @@ ;; ?_) (defun show-chars-with-syntax (tables syntax) - (let ((osyn (syntax-table)) - (schars nil)) + (let ((schars nil)) (unwind-protect (while (consp tables) (let* ((chars nil) (table-symbol (car tables)) - (table table-symbol) - (i 0)) + (table table-symbol)) (or (symbolp table-symbol) (error "bad argument non-symbol")) (while (symbolp table) diff --git a/lisp/syntax.el b/lisp/syntax.el index 99520bb..8835eab 100644 --- a/lisp/syntax.el +++ b/lisp/syntax.el @@ -183,7 +183,7 @@ Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b. b means C is comment starter or comment ender for comment style b." (interactive ;; I really don't know why this is interactive - ;; help-form should at least be made useful whilst reading the second arg + ;; help-form should at least be made useful while reading the second arg "cSet syntax for character: \nsSet syntax for %c to: ") (cond ((syntax-table-p table)) ((not table) diff --git a/lisp/term/internal.el b/lisp/term/internal.el index 1521116..c16a3bb 100644 --- a/lisp/term/internal.el +++ b/lisp/term/internal.el @@ -26,7 +26,7 @@ ;; --------------------------------------------------------------------------- ;; keyboard setup -- that's simple! (set-input-mode nil nil 0) -(define-key function-key-map [backspace] "\177") ; Normal behaviour for BS +(define-key function-key-map [backspace] "\177") ; Normal behavior for BS (define-key function-key-map [delete] "\C-d") ; ... and Delete (define-key function-key-map [tab] [?\t]) (define-key function-key-map [linefeed] [?\n]) diff --git a/lisp/term/sun-mouse.el b/lisp/term/sun-mouse.el index ba577bd..0537147 100644 --- a/lisp/term/sun-mouse.el +++ b/lisp/term/sun-mouse.el @@ -137,46 +137,46 @@ Just like the Common Lisp function of the same name." ;;; All the useful code bits (defmacro sm::hit-code (hit) - (` (nth 0 (, hit)))) + `(nth 0 ,hit)) ;;; The button, or buttons if a chord. (defmacro sm::hit-button (hit) - (` (logand sm::ButtonBits (nth 0 (, hit))))) + `(logand sm::ButtonBits (nth 0 ,hit))) ;;; The shift, control, and meta flags. (defmacro sm::hit-shiftmask (hit) - (` (logand sm::ShiftmaskBits (nth 0 (, hit))))) + `(logand sm::ShiftmaskBits (nth 0 ,hit))) ;;; Set if a double click (but not a chord). (defmacro sm::hit-double (hit) - (` (logand sm::DoubleBits (nth 0 (, hit))))) + `(logand sm::DoubleBits (nth 0 ,hit))) ;;; Set on button release (as opposed to button press). (defmacro sm::hit-up (hit) - (` (logand sm::UpBits (nth 0 (, hit))))) + `(logand sm::UpBits (nth 0 ,hit))) ;;; Screen x position. -(defmacro sm::hit-x (hit) (list 'nth 1 hit)) +(defmacro sm::hit-x (hit) `(nth 1 ,hit)) ;;; Screen y position. -(defmacro sm::hit-y (hit) (list 'nth 2 hit)) +(defmacro sm::hit-y (hit) `(nth 2 ,hit)) ;;; Milliseconds since last hit. -(defmacro sm::hit-delta (hit) (list 'nth 3 hit)) +(defmacro sm::hit-delta (hit) `(nth 3 ,hit)) (defmacro sm::hit-up-p (hit) ; A predicate. - (` (not (zerop (sm::hit-up (, hit)))))) + `(not (zerop (sm::hit-up ,hit)))) ;;; ;;; Loc accessors. for sm::window-xy ;;; -(defmacro sm::loc-w (loc) (list 'nth 0 loc)) -(defmacro sm::loc-x (loc) (list 'nth 1 loc)) -(defmacro sm::loc-y (loc) (list 'nth 2 loc)) +(defmacro sm::loc-w (loc) `(nth 0 ,loc)) +(defmacro sm::loc-x (loc) `(nth 1 ,loc)) +(defmacro sm::loc-y (loc) `(nth 2 ,loc)) ;;; this is used extensively by sun-fns.el ;;; (defmacro eval-in-window (window &rest forms) "Switch to WINDOW, evaluate FORMS, return to original window." - (` (let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (progn - (select-window (, window)) - (,@ forms)) - (select-window OriginallySelectedWindow))))) + `(let ((OriginallySelectedWindow (selected-window))) + (unwind-protect + (progn + (select-window ,window) + ,@forms) + (select-window OriginallySelectedWindow)))) (put 'eval-in-window 'lisp-indent-function 1) ;;; @@ -188,14 +188,14 @@ Just like the Common Lisp function of the same name." "Switches to each window and evaluates FORM. Optional argument YESMINI says to include the minibuffer as a window. This is a macro, and does not evaluate its arguments." - (` (let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (while (progn - (, form) - (not (eq OriginallySelectedWindow - (select-window - (next-window nil (, yesmini))))))) - (select-window OriginallySelectedWindow))))) + `(let ((OriginallySelectedWindow (selected-window))) + (unwind-protect + (while (progn + ,form + (not (eq OriginallySelectedWindow + (select-window + (next-window nil ,yesmini)))))) + (select-window OriginallySelectedWindow)))) (put 'eval-in-window 'lisp-indent-function 0) (defun move-to-loc (x y) diff --git a/lisp/term/sun.el b/lisp/term/sun.el index c5ee5c9..94d443c 100644 --- a/lisp/term/sun.el +++ b/lisp/term/sun.el @@ -217,14 +217,14 @@ (define-key suntool-map "jl" 'kill-region-and-unmark) ; Delete (define-key suntool-map "j\M-l" 'exchange-point-and-mark); M-Delete (define-key suntool-map "j," - '(lambda () (interactive) (pop-mark 1))) ; C-Delete + #'(lambda () (interactive) (pop-mark 1))) ; C-Delete (define-key suntool-map "fT" 'shrink-window-horizontally) ; T6 (define-key suntool-map "gT" 'enlarge-window-horizontally) ; T7 (define-key suntool-map "ft" 'shrink-window) ; t6 (define-key suntool-map "gt" 'enlarge-window) ; t7 -(define-key suntool-map "cT" '(lambda(n) (interactive "p") (scroll-down n))) -(define-key suntool-map "dT" '(lambda(n) (interactive "p") (scroll-up n))) +(define-key suntool-map "cT" #'(lambda(n) (interactive "p") (scroll-down n))) +(define-key suntool-map "dT" #'(lambda(n) (interactive "p") (scroll-up n))) (define-key suntool-map "ct" 'scroll-down-in-place) ; t3 (define-key suntool-map "dt" 'scroll-up-in-place) ; t4 (define-key ctl-x-map "*" suntool-map) diff --git a/lisp/toolbar-items.el b/lisp/toolbar-items.el index 26ed785..171141b 100644 --- a/lisp/toolbar-items.el +++ b/lisp/toolbar-items.el @@ -33,7 +33,7 @@ ;; is compiled in). ;; Miscellaneous toolbar functions, useful for users to redefine, in -;; order to get different behaviour. +;; order to get different behavior. ;;; Code: diff --git a/lisp/toolbar.el b/lisp/toolbar.el index 446ce94..18a0e44 100644 --- a/lisp/toolbar.el +++ b/lisp/toolbar.el @@ -36,9 +36,9 @@ customized through the options menu." :group 'display :type 'boolean - :set '(lambda (var val) - (set-specifier default-toolbar-visible-p val) - (setq toolbar-visible-p val)) + :set #'(lambda (var val) + (set-specifier default-toolbar-visible-p val) + (setq toolbar-visible-p val)) ) (defcustom toolbar-captioned-p ;; added for the options menu - dverna apr. 98 @@ -47,9 +47,9 @@ customized through the options menu." customized through the options menu." :group 'display :type 'boolean - :set '(lambda (var val) - (set-specifier toolbar-buttons-captioned-p val) - (setq toolbar-captioned-p val)) + :set #'(lambda (var val) + (set-specifier toolbar-buttons-captioned-p val) + (setq toolbar-captioned-p val)) ) (defcustom default-toolbar-position ;; added for the options menu - dverna @@ -61,9 +61,9 @@ customized through the options menu." (const :tag "bottom" 'bottom) (const :tag "left" 'left) (const :tag "right" 'right)) - :set '(lambda (var val) - (set-default-toolbar-position val) - (setq default-toolbar-position val)) + :set #'(lambda (var val) + (set-default-toolbar-position val) + (setq default-toolbar-position val)) ) (defvar toolbar-help-enabled t diff --git a/lisp/version.el b/lisp/version.el index 87c1d79..d0ba84c 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -125,7 +125,7 @@ symbol `nil') then only the major version numbers are considered in the test." ;; `what(1)' can extract from the executable or a core file. We don't ;; actually need this to be pointed to from lisp; pure objects can't ;; be GCed. -(or (memq system-type '(vax-vms windows-nt ms-dos)) +(or (memq system-type '(windows-nt ms-dos)) (purecopy (concat "\n@" "(#)" (emacs-version) "\n@" "(#)" "Configuration: " system-configuration "\n"))) diff --git a/lisp/very-early-lisp.el b/lisp/very-early-lisp.el index 2d5a7fa..a6344c4 100644 --- a/lisp/very-early-lisp.el +++ b/lisp/very-early-lisp.el @@ -32,8 +32,6 @@ ;;; Code: -(define-function 'defalias 'define-function) - ;;; Macros from Michael Sperber to replace read-time Lisp reader macros #-, #+ ;;; ####fixme duplicated in make-docfile.el and update-elc.el (defmacro assemble-list (&rest components) diff --git a/lisp/view-less.el b/lisp/view-less.el index 005b80b..23296f9 100644 --- a/lisp/view-less.el +++ b/lisp/view-less.el @@ -148,6 +148,7 @@ "\\\\[scroll-up] = page forward; \\[scroll-down] = page back; \ \\[view-mode-describe] = help; \\[view-quit] = quit."))) +(defvar view-major-mode) (defvar view-exit-position) (defvar view-prev-buffer) (defvar view-exit-action) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index e7a5d96..4939090 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -533,7 +533,7 @@ Suitable for use with `map-extents'." widget-shadow-subrs) (defun widget-put (widget property value) "In WIDGET set PROPERTY to VALUE. -The value can later be retrived with `widget-get'." +The value can later be retrieved with `widget-get'." (setcdr widget (plist-put (cdr widget) property value)))) ;; Recoded in C, for efficiency: @@ -730,7 +730,7 @@ It can also be a valid image instantiator, in which case it will be ;; format. (when (valid-image-instantiator-format-p (caar formats)) (setq file (locate-file image dirlist - (mapconcat 'identity (cdar formats) + (mapconcat #'identity (cdar formats) ":")))) (unless file (pop formats))) @@ -1129,7 +1129,7 @@ Recommended as a parent keymap for modes using widgets.") (error "This widget is inactive")) (let ((current-glyph 'down)) ;; We always know what glyph is drawn currently, to avoid - ;; unnecessary extent changes. Is this any noticable gain? + ;; unnecessary extent changes. Is this any noticeable gain? (unwind-protect (progn ;; Press the glyph. diff --git a/lisp/widget.el b/lisp/widget.el index a0103d9..0586999 100644 --- a/lisp/widget.el +++ b/lisp/widget.el @@ -42,13 +42,12 @@ (defmacro define-widget-keywords (&rest keys) "This doesn't do anything in Emacs 20 or XEmacs." - (` - (eval-and-compile - (let ((keywords (quote (, keys)))) - (while keywords - (or (boundp (car keywords)) - (set (car keywords) (car keywords))) - (setq keywords (cdr keywords))))))) + `(eval-and-compile + (let ((keywords (quote ,keys))) + (while keywords + (or (boundp (car keywords)) + (set (car keywords) (car keywords))) + (setq keywords (cdr keywords)))))) (defun define-widget (name class doc &rest args) "Define a new widget type named NAME from CLASS. diff --git a/lisp/x-compose.el b/lisp/x-compose.el index 0e4d9b1..1500277 100644 --- a/lisp/x-compose.el +++ b/lisp/x-compose.el @@ -104,24 +104,22 @@ (require 'x-iso8859-1) -(defun make-compose-map (map-sym) - (let ((map (make-sparse-keymap))) - (set map-sym map) - (set-keymap-name map map-sym) - ;; Required to tell XEmacs the keymaps were actually autoloaded. - ;; #### Make this unnecessary! - (fset map-sym map))) - -(make-compose-map 'compose-map) -(make-compose-map 'compose-acute-map) -(make-compose-map 'compose-grave-map) -(make-compose-map 'compose-cedilla-map) -(make-compose-map 'compose-diaeresis-map) -(make-compose-map 'compose-circumflex-map) -(make-compose-map 'compose-tilde-map) -(make-compose-map 'compose-ring-map) - -(unintern 'make-compose-map) +(macrolet + ((define-compose-map (keymap-symbol) + `(progn + (defconst ,keymap-symbol (make-sparse-keymap ',keymap-symbol)) + ;; Required to tell XEmacs the keymaps were actually autoloaded. + ;; #### Make this unnecessary! + (fset ',keymap-symbol ,keymap-symbol)))) + + (define-compose-map compose-map) + (define-compose-map compose-acute-map) + (define-compose-map compose-grave-map) + (define-compose-map compose-cedilla-map) + (define-compose-map compose-diaeresis-map) + (define-compose-map compose-circumflex-map) + (define-compose-map compose-tilde-map) + (define-compose-map compose-ring-map)) (define-key compose-map 'acute compose-acute-map) (define-key compose-map 'grave compose-grave-map) @@ -131,28 +129,8 @@ (define-key compose-map 'tilde compose-tilde-map) (define-key compose-map 'degree compose-ring-map) -;;(eval-when-compile -;; (defsubst define-dead-key-map (key map) -;; (define-key function-key-map key map) -;; (define-key compose-map key map))) - -;;;###utoload (autoload 'compose-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-acute-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-grave-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-cedilla-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-diaeresis-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-degree-map "x-compose" nil t 'keymap) -;;;###utoload (define-key function-key-map [acute] 'compose-acute-map) -;;;###utoload (define-key function-key-map [grave] 'compose-grave-map) -;;;###utoload (define-key function-key-map [cedilla] 'compose-cedilla-map) -;;;###utoload (define-key function-key-map [diaeresis] 'compose-diaeresis-map) -;;;###utoload (define-key function-key-map [degree] 'compose-degree-map) -;;;###utoload (define-key function-key-map [multi-key] 'compose-map) -;;;###utoload (define-key global-map [multi-key] 'compose-map) - ;;(define-key function-key-map [multi-key] compose-map) - ;; The following is necessary, because one can't rebind [degree] ;; and use it to insert the degree sign! ;;(defun compose-insert-degree () @@ -160,13 +138,6 @@ ;; (interactive) ;; (insert ?\260)) -;; The "Dead" keys: -;; -;;(define-dead-key-map [acute] compose-acute-map) -;;(define-dead-key-map [cedilla] compose-cedilla-map) -;;(define-dead-key-map [diaeresis] compose-diaeresis-map) -;;(define-dead-key-map [degree] compose-ring-map) - (define-key compose-map [acute] compose-acute-map) (define-key compose-map [?'] compose-acute-map) (define-key compose-map [grave] compose-grave-map) @@ -183,116 +154,6 @@ (define-key compose-map [?*] compose-ring-map) -;;; The dead keys might really be called just about anything, depending -;;; on the vendor. MIT thinks that the prefixes are "SunFA_", "D", and -;;; "hpmute_" for Sun, DEC, and HP respectively. However, OpenWindows 3 -;;; thinks that the prefixes are "SunXK_FA_", "DXK_", and "hpXK_mute_". -;;; And HP (who don't mention Sun and DEC at all) use "XK_mute_". -;;; Go figure. - -;;; Presumably if someone is running OpenWindows, they won't be using -;;; the DEC or HP keysyms, but if they are defined then that is possible, -;;; so in that case we accept them all. - -;;; If things seem not to be working, you might want to check your -;;; /usr/lib/X11/XKeysymDB file to see if your vendor has an equally -;;; mixed up view of what these keys should be called. - -;; Sun according to MIT: -;; - -;;(when (x-valid-keysym-name-p "SunFA_Acute") -;; (define-dead-key-map [SunFA_Acute] compose-acute-map) -;; (define-dead-key-map [SunFA_Grave] compose-grave-map) -;; (define-dead-key-map [SunFA_Cedilla] compose-cedilla-map) -;; (define-dead-key-map [SunFA_Diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [SunFA_Circum] compose-circumflex-map) -;; (define-dead-key-map [SunFA_Tilde] compose-tilde-map) -;; ) -;; -;;;; Sun according to OpenWindows 2: -;;;; -;;(when (x-valid-keysym-name-p "Dead_Grave") -;; (define-dead-key-map [Dead_Grave] compose-grave-map) -;; (define-dead-key-map [Dead_Circum] compose-circumflex-map) -;; (define-dead-key-map [Dead_Tilde] compose-tilde-map) -;; ) -;; -;;;; Sun according to OpenWindows 3: -;;;; -;;(when (x-valid-keysym-name-p "SunXK_FA_Acute") -;; (define-dead-key-map [SunXK_FA_Acute] compose-acute-map) -;; (define-dead-key-map [SunXK_FA_Grave] compose-grave-map) -;; (define-dead-key-map [SunXK_FA_Cedilla] compose-cedilla-map) -;; (define-dead-key-map [SunXK_FA_Diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [SunXK_FA_Circum] compose-circumflex-map) -;; (define-dead-key-map [SunXK_FA_Tilde] compose-tilde-map) -;; ) -;; -;;;; DEC according to MIT: -;;;; -;;(when (x-valid-keysym-name-p "Dacute_accent") -;; (define-dead-key-map [Dacute_accent] compose-acute-map) -;; (define-dead-key-map [Dgrave_accent] compose-grave-map) -;; (define-dead-key-map [Dcedilla_accent] compose-cedilla-map) -;; (define-dead-key-map [Dcircumflex_accent] compose-circumflex-map) -;; (define-dead-key-map [Dtilde] compose-tilde-map) -;; (define-dead-key-map [Dring_accent] compose-ring-map) -;; ) -;; -;;;; DEC according to OpenWindows 3: -;;;; -;;(when (x-valid-keysym-name-p "DXK_acute_accent") -;; (define-dead-key-map [DXK_acute_accent] compose-acute-map) -;; (define-dead-key-map [DXK_grave_accent] compose-grave-map) -;; (define-dead-key-map [DXK_cedilla_accent] compose-cedilla-map) -;; (define-dead-key-map [DXK_circumflex_accent] compose-circumflex-map) -;; (define-dead-key-map [DXK_tilde] compose-tilde-map) -;; (define-dead-key-map [DXK_ring_accent] compose-ring-map) -;; ) -;; -;;;; HP according to MIT: -;;;; -;;(when (x-valid-keysym-name-p "hpmute_acute") -;; (define-dead-key-map [hpmute_acute] compose-acute-map) -;; (define-dead-key-map [hpmute_grave] compose-grave-map) -;; (define-dead-key-map [hpmute_diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [hpmute_asciicircum] compose-circumflex-map) -;; (define-dead-key-map [hpmute_asciitilde] compose-tilde-map) -;; ) -;; -;;;; HP according to OpenWindows 3: -;;;; -;;(when (x-valid-keysym-name-p "hpXK_mute_acute") -;; (define-dead-key-map [hpXK_mute_acute] compose-acute-map) -;; (define-dead-key-map [hpXK_mute_grave] compose-grave-map) -;; (define-dead-key-map [hpXK_mute_diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [hpXK_mute_asciicircum] compose-circumflex-map) -;; (define-dead-key-map [hpXK_mute_asciitilde] compose-tilde-map) -;; ) -;; -;;;; HP according to HP-UX 8.0: -;;;; -;;(when (x-valid-keysym-name-p "XK_mute_acute") -;; (define-dead-key-map [XK_mute_acute] compose-acute-map) -;; (define-dead-key-map [XK_mute_grave] compose-grave-map) -;; (define-dead-key-map [XK_mute_diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [XK_mute_asciicircum] compose-circumflex-map) -;; (define-dead-key-map [XK_mute_asciitilde] compose-tilde-map) -;; ) -;; -;;;; Xfree seems to use lower case and a hyphen -;;(when (x-valid-keysym-name-p "dead-tilde") -;; (define-dead-key-map [dead-acute] compose-acute-map) -;; (define-dead-key-map [dead-grave] compose-grave-map) -;; (define-dead-key-map [dead-cedilla] compose-cedilla-map) -;; (define-dead-key-map [dead-diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [dead-circum] compose-circumflex-map) -;; (define-dead-key-map [dead-tilde] compose-tilde-map) -;; ) - - - ;;; The contents of the "dead key" maps. These are shared by the ;;; compose-map. diff --git a/lisp/x-init.el b/lisp/x-init.el index e9a344f..5df11b2 100644 --- a/lisp/x-init.el +++ b/lisp/x-init.el @@ -101,7 +101,7 @@ (define-key function-key-map [,key] ',map)))) (defun x-initialize-compose () - "Enable compose processing" + "Enable compose key and dead key processing." (autoload 'compose-map "x-compose" nil t 'keymap) (autoload 'compose-acute-map "x-compose" nil t 'keymap) (autoload 'compose-grave-map "x-compose" nil t 'keymap) @@ -212,6 +212,10 @@ (x-define-dead-key dead-tilde compose-tilde-map) ) +(eval-when-compile + (load "x-win-sun" nil t) + (load "x-win-xfree86" nil t)) + (defun x-initialize-keyboard () "Perform X-Server-specific initializations. Don't call this." ;; This is some heuristic junk that tries to guess whether this is @@ -222,47 +226,38 @@ ;; remotely like a Sun - check for the Find key on a particular ;; keycode, for example. It'd be nice to have a table of this to ;; recognize various keyboards; see also xkeycaps. + ;; + ;; Note that we cannot use most vendor-provided proprietary keyboard + ;; APIs to identify the keyboard - those only work on the console. + ;; xkeycaps has the same problem when running `remotely'. (let ((vendor (x-server-vendor))) (cond ((or (string-match "Sun Microsystems" vendor) ;; MIT losingly fails to tell us what hardware the X server ;; is managing, so assume all MIT displays are Suns... HA HA! (string-equal "MIT X Consortium" vendor) (string-equal "X Consortium" vendor)) - ;; Ok, we think this could be a Sun keyboard. Load the Sun code. - ;; (load "x-win-sun")) + ;; Ok, we think this could be a Sun keyboard. Run the Sun code. (x-win-init-sun)) ((string-match "XFree86" vendor) ;; Those XFree86 people do some weird keysym stuff, too. - ;; (load "x-win-xfree86"))))) (x-win-init-xfree86))))) ;; Moved from x-toolbar.el, since InfoDock doesn't dump a x-toolbar.el. (defun x-init-toolbar-from-resources (locale) - (x-init-specifier-from-resources - top-toolbar-height 'natnum locale - '("topToolBarHeight" . "TopToolBarHeight")) - (x-init-specifier-from-resources - bottom-toolbar-height 'natnum locale - '("bottomToolBarHeight" . "BottomToolBarHeight")) - (x-init-specifier-from-resources - left-toolbar-width 'natnum locale - '("leftToolBarWidth" . "LeftToolBarWidth")) - (x-init-specifier-from-resources - right-toolbar-width 'natnum locale - '("rightToolBarWidth" . "RightToolBarWidth")) - (x-init-specifier-from-resources - top-toolbar-border-width 'natnum locale - '("topToolBarBorderWidth" . "TopToolBarBorderWidth")) - (x-init-specifier-from-resources - bottom-toolbar-border-width 'natnum locale - '("bottomToolBarBorderWidth" . "BottomToolBarBorderWidth")) - (x-init-specifier-from-resources - left-toolbar-border-width 'natnum locale - '("leftToolBarBorderWidth" . "LeftToolBarBorderWidth")) - (x-init-specifier-from-resources - right-toolbar-border-width 'natnum locale - '("rightToolBarBorderWidth" . "RightToolBarBorderWidth"))) + (loop for (specifier . resname) in + `(( ,top-toolbar-height . "topToolBarHeight") + (,bottom-toolbar-height . "bottomToolBarHeight") + ( ,left-toolbar-width . "leftToolBarWidth") + ( ,right-toolbar-width . "rightToolBarWidth") + + ( ,top-toolbar-border-width . "topToolBarBorderWidth") + (,bottom-toolbar-border-width . "bottomToolBarBorderWidth") + ( ,left-toolbar-border-width . "leftToolBarBorderWidth") + ( ,right-toolbar-border-width . "rightToolBarBorderWidth")) + do + (x-init-specifier-from-resources + specifier 'natnum locale (cons resname (upcase-initials resname))))) (defvar pre-x-win-initted nil) @@ -282,6 +277,7 @@ (defun init-x-win () "Initialize X Windows at startup. Don't call this." (when (not x-win-initted) + (defvar x-app-defaults-directory) (init-pre-x-win) ;; Open the X display when this file is loaded @@ -314,16 +310,16 @@ ;; these are only ever called if zmacs-regions is true. (add-hook 'zmacs-deactivate-region-hook (lambda () - (if (console-on-window-system-p) - (x-disown-selection)))) + (when (console-on-window-system-p) + (x-disown-selection)))) (add-hook 'zmacs-activate-region-hook (lambda () - (if (console-on-window-system-p) - (x-activate-region-as-selection)))) + (when (console-on-window-system-p) + (x-activate-region-as-selection)))) (add-hook 'zmacs-update-region-hook (lambda () - (if (console-on-window-system-p) - (x-activate-region-as-selection)))) + (when (console-on-window-system-p) + (x-activate-region-as-selection)))) ;; Motif-ish bindings ;; The following two were generally unliked. ;;(define-key global-map '(shift delete) 'kill-primary-selection) diff --git a/lisp/x-iso8859-1.el b/lisp/x-iso8859-1.el index 866f761..38788ce 100644 --- a/lisp/x-iso8859-1.el +++ b/lisp/x-iso8859-1.el @@ -44,7 +44,7 @@ ;; keys are bound to one-character keyboard macros, so that `kp-9' will, by ;; default, do the same thing that `9' does, in whatever the current mode is. -;; The standard case and syntax tables are set in prim/iso8859-1.el, since +;; The standard case and syntax tables are set in iso8859-1.el, since ;; that is not X-specific. ;;; Code: @@ -71,16 +71,16 @@ possible, in the interest of portability.") ;; the keysym symbols. ;; (mapcar '(lambda (sym-and-code) - (list 'put (list 'quote (car sym-and-code)) - ''x-iso8859/1 (car (cdr sym-and-code)))) + (list 'put (list 'quote (car sym-and-code)) + ''x-iso8859/1 (car (cdr sym-and-code)))) syms-and-iso8859/1-codes) ;; ;; Then emit code that binds all of those keysym symbols to ;; `self-insert-command'. ;; (mapcar '(lambda (sym-and-code) - (list 'global-set-key (list 'quote (car sym-and-code)) - ''self-insert-command)) + (list 'global-set-key (list 'quote (car sym-and-code)) + ''self-insert-command)) syms-and-iso8859/1-codes) ;; ;; Then emit the value of iso8859/1-code-to-x-keysym-table. @@ -96,8 +96,8 @@ possible, in the interest of portability.") '((8 backspace) (9 tab) (10 linefeed) (13 return) (27 escape) (32 space) (127 delete))) (mapcar '(lambda (sym-and-code) - (or (aref v (car (cdr sym-and-code))) - (aset v (car (cdr sym-and-code)) (car sym-and-code)))) + (or (aref v (car (cdr sym-and-code))) + (aset v (car (cdr sym-and-code)) (car sym-and-code)))) syms-and-iso8859/1-codes) (list (list 'setq 'iso8859/1-code-to-x-keysym-table v))) )))) @@ -211,8 +211,8 @@ possible, in the interest of portability.") ((macro . (lambda (&rest syms-and-iso8859/1-codes) (cons 'progn (mapcar '(lambda (sym-and-code) - (list 'put (list 'quote (car sym-and-code)) - ''x-iso8859/1 (car (cdr sym-and-code)))) + (list 'put (list 'quote (car sym-and-code)) + ''x-iso8859/1 (car (cdr sym-and-code)))) syms-and-iso8859/1-codes)))) ;; ;; Let's do the appropriate thing for some vendor-specific keysyms too... diff --git a/lisp/x-mouse.el b/lisp/x-mouse.el index ba35ea2..f5c06aa 100644 --- a/lisp/x-mouse.el +++ b/lisp/x-mouse.el @@ -119,7 +119,7 @@ A mark is pushed, so that the inserted text lies between point and mark." (set-buffer (extent-object (car primary-selection-extent))) (x-store-cutbuffer (mapconcat - 'identity + #'identity (extract-rectangle (extent-start-position (car primary-selection-extent)) (extent-end-position (car (reverse primary-selection-extent)))) diff --git a/lisp/x-win-sun.el b/lisp/x-win-sun.el index 0bebfaa..b59dd82 100644 --- a/lisp/x-win-sun.el +++ b/lisp/x-win-sun.el @@ -64,19 +64,9 @@ ;;; Code: +;;;###autoload (defun x-win-init-sun () - (defun x-remap-keysyms-using-function-key-map (from-key to-key) - (dolist (prefix '(() (shift) (control) (meta) (alt) - (shift control) (shift alt) (shift meta) - (control alt) (control meta) (alt meta) - (shift control alt) (shift control meta) - (shift alt meta) (control alt meta) - (shift control alt meta))) - (define-key function-key-map - (append prefix (list from-key)) - (vector (append prefix (list to-key)))))) - ;; help is ok ;; num_lock is ok ;; up is ok @@ -164,9 +154,15 @@ (f12 again)))) ) do (when (x-keysym-on-keyboard-sans-modifiers-p from-key) - (x-remap-keysyms-using-function-key-map from-key to-key))) - - (unintern 'x-remap-keysyms-using-function-key-map) + (dolist (prefix '(() (shift) (control) (meta) (alt) + (shift control) (shift alt) (shift meta) + (control alt) (control meta) (alt meta) + (shift control alt) (shift control meta) + (shift alt meta) (control alt meta) + (shift control alt meta))) + (define-key function-key-map + (append prefix (list from-key)) + (vector (append prefix (list to-key))))))) ;; for each element in the left column of the above table, alias it ;; to the thing in the right column. Then do the same for many, but diff --git a/lisp/x-win-xfree86.el b/lisp/x-win-xfree86.el index 14c0d61..d376a7b 100644 --- a/lisp/x-win-xfree86.el +++ b/lisp/x-win-xfree86.el @@ -39,6 +39,7 @@ ;; For no obvious reason, shift-F1 is called F13, although Meta-F1 and ;; Control-F1 have normal names. +;;;###autoload (defun x-win-init-xfree86 () (loop for (key sane-key) in '((f13 f1) diff --git a/lwlib/Makefile.in.in b/lwlib/Makefile.in.in index 4fe3fff..6a3774d 100644 --- a/lwlib/Makefile.in.in +++ b/lwlib/Makefile.in.in @@ -32,7 +32,7 @@ SHELL=/bin/sh RM = rm -f AR = ar cq -CC=@CC@ +CC=@XEMACS_CC@ CPP=@CPP@ CFLAGS=@CFLAGS@ CPPFLAGS=@CPPFLAGS@ diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index 12dca51..cf4de8d 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -83,23 +83,23 @@ xlwMenuResources[] = /* We must use an iso8859-1 font here, or people without $LANG set lose. It's fair to assume that those who do have $LANG set also have the *fontList resource set, or at least know how to deal with this. */ - XtRString, "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-1"}, + XtRString, (XtPointer) "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-1"}, #else {XtNfont, XtCFont, XtRFontStruct, sizeof(XFontStruct *), - offset(menu.font), XtRString, "XtDefaultFont"}, + offset(menu.font), XtRString, (XtPointer) "XtDefaultFont"}, # ifdef USE_XFONTSET {XtNfontSet, XtCFontSet, XtRFontSet, sizeof(XFontSet), - offset(menu.font_set), XtRString, "XtDefaultFontSet"}, + offset(menu.font_set), XtRString, (XtPointer) "XtDefaultFontSet"}, # endif #endif {XtNforeground, XtCForeground, XtRPixel, sizeof(Pixel), - offset(menu.foreground), XtRString, "XtDefaultForeground"}, + offset(menu.foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNbuttonForeground, XtCButtonForeground, XtRPixel, sizeof(Pixel), - offset(menu.button_foreground), XtRString, "XtDefaultForeground"}, + offset(menu.button_foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNhighlightForeground, XtCHighlightForeground, XtRPixel, sizeof(Pixel), - offset(menu.highlight_foreground), XtRString, "XtDefaultForeground"}, + offset(menu.highlight_foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNtitleForeground, XtCTitleForeground, XtRPixel, sizeof(Pixel), - offset(menu.title_foreground), XtRString, "XtDefaultForeground"}, + offset(menu.title_foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNmargin, XtCMargin, XtRDimension, sizeof(Dimension), offset(menu.margin), XtRImmediate, (XtPointer)2}, {XmNmarginWidth, XmCMarginWidth, XmRHorizontalDimension, sizeof(Dimension), @@ -867,16 +867,16 @@ string_draw_u (XlwMenuWidget mw, #endif ) { -int i,s=0; -char *chars; + int i, s = 0; + char *chars; #ifdef NEED_MOTIF XmStringGetLtoR (string, XmFONTLIST_DEFAULT_TAG, &chars); #else chars = string; #endif - for (i=0;chars[i];++i) { - if (chars[i]=='%'&&chars[i+1]=='_') { + for (i=0; chars[i]; ++i) { + if (chars[i] == '%' && chars[i+1] == '_') { int w; x += string_draw_range (mw, window, x, y, gc, chars, s, i); @@ -1475,7 +1475,7 @@ print_widget_value (widget_value *wv, int just_one, int depth) print_widget_value (wv->next, 0, depth); } } -#endif +#endif /* SLOPPY_TYPES < 2 */ static Boolean all_dashes_p (char *s) @@ -1489,30 +1489,29 @@ all_dashes_p (char *s) return True; return False; } -#endif +#endif /* SLOPPY_TYPES */ static widget_value_type menu_item_type (widget_value *val) { if (val->type != UNSPECIFIED_TYPE) return val->type; - else - { #if SLOPPY_TYPES - if (all_dashes_p (val->name)) - return SEPARATOR_TYPE; - else if (val->name && val->name[0] == '\0') /* push right */ - return PUSHRIGHT_TYPE; - else if (val->contents) /* cascade */ - return CASCADE_TYPE; - else if (val->call_data) /* push button */ - return BUTTON_TYPE; - else - return TEXT_TYPE; + else if (all_dashes_p (val->name)) + return SEPARATOR_TYPE; + else if (val->name && val->name[0] == '\0') /* push right */ + return PUSHRIGHT_TYPE; + else if (val->contents) /* cascade */ + return CASCADE_TYPE; + else if (val->call_data) /* push button */ + return BUTTON_TYPE; + else + return TEXT_TYPE; #else + else abort(); + return UNSPECIFIED_TYPE; /* Not reached */ #endif - } } static void diff --git a/man/ChangeLog b/man/ChangeLog index 8217209..ef54442 100644 --- a/man/ChangeLog +++ b/man/ChangeLog @@ -1,3 +1,72 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + +1998-11-30 Martin Buchholz + + * xemacs/startup.texi (Startup Paths): + * xemacs/custom.texi (Widgets): + * xemacs-faq.texi (Q3.0.5): + * xemacs-faq.texi (Top): + + * widget.texi (info-link): + + * lispref/objects.texi (Type Predicates): + * lispref/objects.texi (Hash Table Type): + * lispref/objects.texi (Primitive Types): + * lispref/objects.texi (Lisp Data Types): + * lispref/macros.texi (Backquote): + * lispref/hash-tables.texi (Weak Hash Tables): + * lispref/hash-tables.texi: + * lispref/errors.texi (Standard Errors): + * lispref/compile.texi (Disassembly): + * lispref/compile.texi (Compiled-Function Objects): + * lispref/compile.texi (Eval During Compile): + * lispref/compile.texi (Docs and Compilation): + * lispref/compile.texi (Compilation Functions): + * lispref/compile.texi (Speed of Byte-Code): + * lispref/compile.texi (Byte Compilation): + * lispref/building.texi (Garbage Collection): + + * internals/internals.texi (Simple Special Forms): + * internals/internals.texi (Evaluation; Stack Frames; Bindings): + * internals/internals.texi (Specifics of the Event Gathering Mechanism): + * internals/internals.texi (String): + * internals/internals.texi (Introduction to Allocation): + * internals/internals.texi (Allocation of Objects in XEmacs Lisp): + * internals/internals.texi (Modules for Internationalization): + * internals/internals.texi (Modules for Interfacing with X Windows): + * internals/internals.texi (Modules for Interfacing with the Operating System): + * internals/internals.texi (Modules for Other Aspects of the Lisp Interpreter and Object System): + * internals/internals.texi (Modules for Interfacing with the File System): + * internals/internals.texi (Modules for the Redisplay Mechanism): + * internals/internals.texi (Modules for the Basic Displayable Lisp Objects): + * internals/internals.texi (Editor-Level Control Flow Modules): + * internals/internals.texi (Modules for Standard Editing Operations): + * internals/internals.texi (Basic Lisp Modules): + * internals/internals.texi (Low-Level Modules): + * internals/internals.texi (A Summary of the Various XEmacs Modules): + * internals/internals.texi (An Example of Mule-Aware Code): + * internals/internals.texi (Working With Character and Byte Positions): + * internals/internals.texi (Writing Lisp Primitives): + * internals/internals.texi (General Coding Rules): + * internals/internals.texi (How Lisp Objects Are Represented in C): + * internals/internals.texi (The XEmacs Object System (Abstractly Speaking)): + * internals/internals.texi (XEmacs From the Perspective of Building): + * internals/internals.texi (The Lisp Language): + * internals/internals.texi (Top): + * internals/internals.texi: + - rewrite Internals manual + + * cl.texi (Porting Common Lisp): + * cl.texi (Hash Tables): + * cl.texi (Association Lists): + * cl.texi (Declarations): + * cl.texi (For Clauses): + * cl.texi (Basic Setf): + * cl.texi (Equality Predicates): + - mega patch + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff --git a/man/cl.texi b/man/cl.texi index 7538e51..f7607c9 100644 --- a/man/cl.texi +++ b/man/cl.texi @@ -947,13 +947,9 @@ it compares numbers without regard to type (so that @code{(equalp 3 objects are compared as if by @code{equal}. This function differs from Common Lisp @code{equalp} in several -respects. First, in keeping with the idea that strings are less +respects. In keeping with the idea that strings are less vector-like in Emacs Lisp, this package's @code{equalp} also will not -compare strings against vectors of integers. Second, Common Lisp's -@code{equalp} compares hash tables without regard to ordering, whereas -this package simply compares hash tables in terms of their underlying -structure (which means vectors for Lucid Emacs 19 hash tables, or lists -for other hash tables). +compare strings against vectors of integers. @end defun Also note that the Common Lisp functions @code{member} and @code{assoc} @@ -1098,44 +1094,44 @@ to standard Common Lisp. @item The following Emacs-specific functions are also @code{setf}-able. -(Some of these are defined only in Emacs 19 or only in Lucid Emacs.) +(Some of these are defined only in Emacs 19 or only in XEmacs.) @smallexample -buffer-file-name marker-position -buffer-modified-p match-data -buffer-name mouse-position -buffer-string overlay-end -buffer-substring overlay-get -current-buffer overlay-start -current-case-table point -current-column point-marker -current-global-map point-max -current-input-mode point-min -current-local-map process-buffer -current-window-configuration process-filter -default-file-modes process-sentinel -default-value read-mouse-position -documentation-property screen-height -extent-data screen-menubar -extent-end-position screen-width -extent-start-position selected-window -face-background selected-screen -face-background-pixmap selected-frame -face-font standard-case-table -face-foreground syntax-table -face-underline-p window-buffer -file-modes window-dedicated-p -frame-height window-display-table -frame-parameters window-height -frame-visible-p window-hscroll -frame-width window-point -get-register window-start -getenv window-width -global-key-binding x-get-cut-buffer -keymap-parent x-get-cutbuffer +buffer-file-name marker-position +buffer-modified-p match-data +buffer-name mouse-position +buffer-string overlay-end +buffer-substring overlay-get +current-buffer overlay-start +current-case-table point +current-column point-marker +current-global-map point-max +current-input-mode point-min +current-local-map process-buffer +current-window-configuration process-filter +default-file-modes process-sentinel +default-value read-mouse-position +documentation-property screen-height +extent-data screen-menubar +extent-end-position screen-width +extent-start-position selected-window +face-background selected-screen +face-background-pixmap selected-frame +face-font standard-case-table +face-foreground syntax-table +face-underline-p window-buffer +file-modes window-dedicated-p +frame-height window-display-table +frame-parameters window-height +frame-visible-p window-hscroll +frame-width window-point +get-register window-start +getenv window-width +global-key-binding x-get-cut-buffer +keymap-parent x-get-cutbuffer local-key-binding x-get-secondary-selection -mark x-get-selection -mark-marker +mark x-get-selection +mark-marker @end smallexample Most of these have directly corresponding ``set'' functions, like @@ -2584,14 +2580,14 @@ is the opposite word of the word following @code{the}) to cause hash table entry. @item for @var{var} being the key-codes of @var{keymap} -This clause iterates over the entries in @var{keymap}. In GNU Emacs -18 and 19, keymaps are either alists or vectors, and key-codes are -integers or symbols. In Lucid Emacs 19, keymaps are a special new -data type, and key-codes are symbols or lists of symbols. The -iteration does not enter nested keymaps or inherited (parent) keymaps. -You can use @samp{the key-bindings} to access the commands bound to -the keys rather than the key codes, and you can add a @code{using} -clause to access both the codes and the bindings together. +This clause iterates over the entries in @var{keymap}. In GNU Emacs 18 +and 19, keymaps are either alists or vectors, and key-codes are integers +or symbols. In XEmacs, keymaps are a special new data type, and +key-codes are symbols or lists of symbols. The iteration does not enter +nested keymaps or inherited (parent) keymaps. You can use @samp{the +key-bindings} to access the commands bound to the keys rather than the +key codes, and you can add a @code{using} clause to access both the +codes and the bindings together. @item for @var{var} being the key-seqs of @var{keymap} This clause iterates over all key sequences defined by @var{keymap} @@ -2602,13 +2598,13 @@ them permanently. You can add a @samp{using (key-bindings ...)} clause to get the command bindings as well. @item for @var{var} being the overlays [of @var{buffer}] @dots{} -This clause iterates over the Emacs 19 ``overlays'' or Lucid -Emacs ``extents'' of a buffer (the clause @code{extents} is synonymous -with @code{overlays}). Under Emacs 18, this clause iterates zero -times. If the @code{of} term is omitted, the current buffer is used. -This clause also accepts optional @samp{from @var{pos}} and -@samp{to @var{pos}} terms, limiting the clause to overlays which -overlap the specified region. +This clause iterates over the Emacs 19 ``overlays'' or XEmacs +``extents'' of a buffer (the clause @code{extents} is synonymous with +@code{overlays}). Under Emacs 18, this clause iterates zero times. If +the @code{of} term is omitted, the current buffer is used. This clause +also accepts optional @samp{from @var{pos}} and @samp{to @var{pos}} +terms, limiting the clause to overlays which overlap the specified +region. @item for @var{var} being the intervals [of @var{buffer}] @dots{} This clause iterates over all intervals of a buffer with constant @@ -3217,7 +3213,7 @@ Emacs 19. @example (declaim (inline foo bar)) (eval-when (compile load eval) (proclaim '(inline foo bar))) -(proclaim-inline foo bar) ; Lucid Emacs only +(proclaim-inline foo bar) ; XEmacs only (defsubst foo (...) ...) ; instead of defun; Emacs 19 only @end example @@ -4601,6 +4597,10 @@ This is equivalent to @code{(nconc (mapcar* 'cons @var{keys} @var{values}) @chapter Hash Tables @noindent +Hash tables are now implemented directly in the C code and documented in +@ref{Hash Tables,,, lispref, XEmacs Lisp Programmer's Manual}. + +@ignore A @dfn{hash table} is a data structure that maps ``keys'' onto ``values.'' Keys and values can be arbitrary Lisp data objects. Hash tables have the property that the time to search for a given @@ -4622,14 +4622,14 @@ though if you use something else you should check the details of the hashing function described below to make sure it is suitable for your predicate. -Some versions of Emacs (like Lucid Emacs 19) include a built-in -hash table type; in these versions, @code{make-hash-table} with -a test of @code{eq} will use these built-in hash tables. In all -other cases, it will return a hash-table object which takes the -form of a list with an identifying ``tag'' symbol at the front. -All of the hash table functions in this package can operate on -both types of hash table; normally you will never know which -type is being used. +Some versions of Emacs (like XEmacs) include a built-in hash +table type; in these versions, @code{make-hash-table} with a test of +@code{eq}, @code{eql}, or @code{equal} will use these built-in hash +tables. In all other cases, it will return a hash-table object which +takes the form of a list with an identifying ``tag'' symbol at the +front. All of the hash table functions in this package can operate on +both types of hash table; normally you will never know which type is +being used. This function accepts the additional Common Lisp keywords @code{:rehash-size} and @code{:rehash-threshold}, but it ignores @@ -4670,22 +4670,20 @@ of the given entry. The return value of @var{function} is ignored; an alternate way of iterating over hash tables. @end defun -@defun hash-table-count table -This function returns the number of entries in @var{table}. -@strong{Warning:} The current implementation of Lucid Emacs 19 -hash-tables does not decrement the stored @code{count} when -@code{remhash} removes an entry. Therefore, the return value of -this function is not dependable if you have used @code{remhash} -on the table and the table's test is @code{eq}. A slower, but -reliable, way to count the entries is @code{(loop for x being the -hash-keys of @var{table} count t)}. +@defun hash-table-count table This function returns the number of +entries in @var{table}. @strong{Warning:} The current implementation of +XEmacs hash-tables does not decrement the stored @code{count} +when @code{remhash} removes an entry. Therefore, the return value of +this function is not dependable if you have used @code{remhash} on the +table and the table's test is @code{eq}, @code{eql}, or @code{equal}. +A slower, but reliable, way to count the entries is +@code{(loop for x being the hash-keys of @var{table} count t)}. @end defun -@defun hash-table-p object -This function returns @code{t} if @var{object} is a hash table, -@code{nil} otherwise. It recognizes both types of hash tables -(both Lucid Emacs built-in tables and tables implemented with -special lists.) +@defun hash-table-p object This function returns @code{t} if +@var{object} is a hash table, @code{nil} otherwise. It recognizes both +types of hash tables (both XEmacs built-in tables and tables implemented +with special lists.) @end defun Sometimes when dealing with hash tables it is useful to know the @@ -4745,6 +4743,7 @@ structure will be more efficient since lookup does not require converting the key to a string or looking it up in an obarray. However, such tables are guaranteed to take time proportional to their size to do a search. +@end ignore @iftex @chapno=18 @@ -5581,7 +5580,7 @@ the @code{lambda} expression is code that can be compiled. (mapcar (function (lambda (x) (* x 2))) list) ; Emacs Lisp @end example -Lucid Emacs supports @code{#'} notation starting with version 19.8. +XEmacs supports @code{#'} notation starting with version 19.8. @item Reader macros. Common Lisp includes a second type of macro that diff --git a/man/internals/internals.texi b/man/internals/internals.texi index 59d4c50..d9043c3 100644 --- a/man/internals/internals.texi +++ b/man/internals/internals.texi @@ -8,7 +8,7 @@ Copyright @copyright{} 1992 - 1996 Ben Wing. Copyright @copyright{} 1996, 1997 Sun Microsystems. -Copyright @copyright{} 1994, 1995 Free Software Foundation. +Copyright @copyright{} 1994 - 1998 Free Software Foundation. Copyright @copyright{} 1994, 1995 Board of Trustees, University of Illinois. @@ -59,22 +59,23 @@ instead of in the original English. @titlepage @title XEmacs Internals Manual -@subtitle Version 1.1, March 1997 +@subtitle Version 1.2, October 1998 @author Ben Wing @author Martin Buchholz +@author Hrvoje Niksic @page @vskip 0pt plus 1fill @noindent Copyright @copyright{} 1992 - 1996 Ben Wing. @* -Copyright @copyright{} 1996 Sun Microsystems, Inc. @* -Copyright @copyright{} 1994 Free Software Foundation. @* +Copyright @copyright{} 1996, 1997 Sun Microsystems, Inc. @* +Copyright @copyright{} 1994 - 1998 Free Software Foundation. @* Copyright @copyright{} 1994, 1995 Board of Trustees, University of Illinois. @sp 2 -Version 1.1 @* -March, 1997.@* +Version 1.2 @* +October 1998.@* Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are @@ -180,7 +181,7 @@ Allocation of Objects in XEmacs Lisp * Symbol:: * Marker:: * String:: -* Bytecode:: +* Compiled Function:: Events and the Event Loop @@ -908,10 +909,43 @@ of types and functions are declared to accept only certain types, thus providing the increased compile-time error-checking of static typing. @end enumerate +The Java language also has some negative attributes: + +@enumerate +@item +Java uses the edit/compile/run model of software development. This +makes it hard to use interactively. For example, to use Java like +@code{bc} it is necessary to write a special purpose, albeit tiny, +application. In Emacs Lisp, a calculator comes built-in without any +effort - one can always just type an expression in the @code{*scratch*} +buffer. +@item +Java tries too hard to enforce, not merely enable, portability, making +ordinary access to standard OS facilities painful. Java has an +@dfn{agenda}. I think this is why @code{chdir} is not part of standard +Java, which is inexcusable. +@end enumerate + +Unfortunately, there is no perfect language. Static typing allows a +compiler to catch programmer errors and produce more efficient code, but +makes programming more tedious and less fun. For the forseeable future, +an Ideal Editing and Programming Environment (and that is what XEmacs +aspires to) will be programmable in multiple languages: high level ones +like Lisp for user customization and prototyping, and lower level ones +for infrastructure and industrial strength applications. If I had my +way, XEmacs would be friendly towards the Python, Scheme, C++, ML, +etc... communities. But there are serious technical difficulties to +achieving that goal. + +The word @dfn{application} in the previous paragraph was used +intentionally. XEmacs implements an API for programs written in Lisp +that makes it a full-fledged application platform, very much like an OS +inside the real OS. + @node XEmacs From the Perspective of Building, XEmacs From the Inside, The Lisp Language, Top @chapter XEmacs From the Perspective of Building - The heart of XEmacs is the Lisp environment, which is written in C. +The heart of XEmacs is the Lisp environment, which is written in C. This is contained in the @file{src/} subdirectory. Underneath @file{src/} are two subdirectories of header files: @file{s/} (header files for particular operating systems) and @file{m/} (header files for @@ -923,26 +957,26 @@ of the configure process, one @file{s/} file and one @file{m/} file is identified for the particular environment in which XEmacs is being built. - XEmacs also contains a great deal of Lisp code. This implements the -operations that make XEmacs useful as an editor as well as just a -Lisp environment, and also contains many add-on packages that allow -XEmacs to browse directories, act as a mail and Usenet news reader, -compile Lisp code, etc. There is actually more Lisp code than -C code associated with XEmacs, but much of the Lisp code is -peripheral to the actual operation of the editor. The Lisp code -all lies in subdirectories underneath the @file{lisp/} directory. +XEmacs also contains a great deal of Lisp code. This implements the +operations that make XEmacs useful as an editor as well as just a Lisp +environment, and also contains many add-on packages that allow XEmacs to +browse directories, act as a mail and Usenet news reader, compile Lisp +code, etc. There is actually more Lisp code than C code associated with +XEmacs, but much of the Lisp code is peripheral to the actual operation +of the editor. The Lisp code all lies in subdirectories underneath the +@file{lisp/} directory. - The @file{lwlib/} directory contains C code that implements a +The @file{lwlib/} directory contains C code that implements a generalized interface onto different X widget toolkits and also implements some widgets of its own that behave like Motif widgets but are faster, free, and in some cases more powerful. The code in this directory compiles into a library and is mostly independent from XEmacs. - The @file{etc/} directory contains various data files associated with +The @file{etc/} directory contains various data files associated with XEmacs. Some of them are actually read by XEmacs at startup; others merely contain useful information of various sorts. - The @file{lib-src/} directory contains C code for various auxiliary +The @file{lib-src/} directory contains C code for various auxiliary programs that are used in connection with XEmacs. Some of them are used during the build process; others are used to perform certain functions that cannot conveniently be placed in the XEmacs executable (e.g. the @@ -951,59 +985,64 @@ which must be setgid to @file{mail} on many systems; and the @file{gnuclient} program, which allows an external script to communicate with a running XEmacs process). - The @file{man/} directory contains the sources for the XEmacs +The @file{man/} directory contains the sources for the XEmacs documentation. It is mostly in a form called Texinfo, which can be converted into either a printed document (by passing it through @TeX{}) or into on-line documentation called @dfn{info files}. - The @file{info/} directory contains the results of formatting the -XEmacs documentation as @dfn{info files}, for on-line use. These files -are used when you enter the Info system using @kbd{C-h i} or through the +The @file{info/} directory contains the results of formatting the XEmacs +documentation as @dfn{info files}, for on-line use. These files are +used when you enter the Info system using @kbd{C-h i} or through the Help menu. - The @file{dynodump/} directory contains auxiliary code used to build +The @file{dynodump/} directory contains auxiliary code used to build XEmacs on Solaris platforms. - The other directories contain various miscellaneous code and -information that is not normally used or needed. - - The first step of building involves running the @file{configure} -program and passing it various parameters to specify any optional -features you want and compiler arguments and such, as described in the -@file{INSTALL} file. This determines what the build environment is, -chooses the appropriate @file{s/} and @file{m/} file, and runs a series -of tests to determine many details about your environment, such as which -library functions are available and exactly how they work. (The -@file{s/} and @file{m/} files only contain information that cannot be -conveniently detected in this fashion.) The reason for running these -tests is that it allows XEmacs to be compiled on a much wider variety of -platforms than those that the XEmacs developers happen to be familiar -with, including various sorts of hybrid platforms. This is especially -important now that many operating systems give you a great deal of -control over exactly what features you want installed, and allow for -easy upgrading of parts of a system without upgrading the rest. It +The other directories contain various miscellaneous code and information +that is not normally used or needed. + +The first step of building involves running the @file{configure} program +and passing it various parameters to specify any optional features you +want and compiler arguments and such, as described in the @file{INSTALL} +file. This determines what the build environment is, chooses the +appropriate @file{s/} and @file{m/} file, and runs a series of tests to +determine many details about your environment, such as which library +functions are available and exactly how they work. The reason for +running these tests is that it allows XEmacs to be compiled on a much +wider variety of platforms than those that the XEmacs developers happen +to be familiar with, including various sorts of hybrid platforms. This +is especially important now that many operating systems give you a great +deal of control over exactly what features you want installed, and allow +for easy upgrading of parts of a system without upgrading the rest. It would be impossible to pre-determine and pre-specify the information for all possible configurations. - When configure is done running, it generates @file{Makefile}s and the -file @file{src/config.h} (which describes the features of your system) -from template files. You then run @file{make}, which compiles the -auxiliary code and programs in @file{lib-src/} and @file{lwlib/} and the -main XEmacs executable in @file{src/}. The result of compiling and -linking is an executable called @file{temacs}, which is @emph{not} the -final XEmacs executable. @file{temacs} by itself is not intended to -function as an editor or even display any windows on the screen, and if -you simply run it, it will exit immediately. The @file{Makefile} runs -@file{temacs} with certain options that cause it to initialize itself, -read in a number of basic Lisp files, and then dump itself out into a -new executable called @file{xemacs}. This new executable has been -pre-initialized and contains pre-digested Lisp code that is necessary -for the editor to function (this includes most basic Lisp functions, -e.g. @code{not}, that can be defined in terms of other Lisp primitives; -some initialization code that is called when certain objects, such as -frames, are created; and all of the standard keybindings and code for -the actions they result in). This executable, @file{xemacs}, is the -executable that you run to use the XEmacs editor. +In fact, the @file{s/} and @file{m/} files are basically @emph{evil}, +since they contain unmaintainable platform-specific hard-coded +information. XEmacs has been moving in the direction of having all +system-specific information be determined dynamically by +@file{configure}. Perhaps someday we can @code{rm -rf src/s src/m}. + +When configure is done running, it generates @file{Makefile}s and +@file{GNUmakefile}s and the file @file{src/config.h} (which describes +the features of your system) from template files. You then run +@file{make}, which compiles the auxiliary code and programs in +@file{lib-src/} and @file{lwlib/} and the main XEmacs executable in +@file{src/}. The result of compiling and linking is an executable +called @file{temacs}, which is @emph{not} the final XEmacs executable. +@file{temacs} by itself is not intended to function as an editor or even +display any windows on the screen, and if you simply run it, it will +exit immediately. The @file{Makefile} runs @file{temacs} with certain +options that cause it to initialize itself, read in a number of basic +Lisp files, and then dump itself out into a new executable called +@file{xemacs}. This new executable has been pre-initialized and +contains pre-digested Lisp code that is necessary for the editor to +function (this includes most basic editing functions, +e.g. @code{kill-line}, that can be defined in terms of other Lisp +primitives; some initialization code that is called when certain +objects, such as frames, are created; and all of the standard +keybindings and code for the actions they result in). This executable, +@file{xemacs}, is the executable that you run to use the XEmacs editor. Although @file{temacs} is not intended to be run as an editor, it can, by using the incantation @code{temacs -batch -l loadup.el run-temacs}. @@ -1015,7 +1054,7 @@ such as allocation memory in one process, and freeing it in the next. @node XEmacs From the Inside, The XEmacs Object System (Abstractly Speaking), XEmacs From the Perspective of Building, Top @chapter XEmacs From the Inside - Internally, XEmacs is quite complex, and can be very confusing. To +Internally, XEmacs is quite complex, and can be very confusing. To simplify things, it can be useful to think of XEmacs as containing an event loop that ``drives'' everything, and a number of other subsystems, such as a Lisp engine and a redisplay mechanism. Each of these other @@ -1023,7 +1062,7 @@ subsystems exists simultaneously in XEmacs, and each has a certain state. The flow of control continually passes in and out of these different subsystems in the course of normal operation of the editor. - It is important to keep in mind that, most of the time, the editor is +It is important to keep in mind that, most of the time, the editor is ``driven'' by the event loop. Except during initialization and batch mode, all subsystems are entered directly or indirectly through the event loop, and ultimately, control exits out of all subsystems back up @@ -1031,7 +1070,7 @@ to the event loop. This cycle of entering a subsystem, exiting back out to the event loop, and starting another iteration of the event loop occurs once each keystroke, mouse motion, etc. - If you're trying to understand a particular subsystem (other than the +If you're trying to understand a particular subsystem (other than the event loop), think of it as a ``daemon'' process or ``servant'' that is responsible for one particular aspect of a larger system, and periodically receives commands or environment changes that cause it to @@ -1187,9 +1226,9 @@ in its internal operations.) @table @code @item integer -28 bits of precision, or 60 bits on 64-bit machines; the reason for this -is described below when the internal Lisp object representation is -described. +28 or 31 bits of precision, or 60 or 63 bits on 64-bit machines; the +reason for this is described below when the internal Lisp object +representation is described. @item float Same precision as a double in C. @item cons @@ -1223,29 +1262,30 @@ are more limited. @item string Self-explanatory; behaves much like a vector of chars but has a different read syntax and is stored and manipulated -more compactly and efficiently. +more compactly. @item bit-vector A vector of bits; similar to a string in spirit. @item compiled-function -An object describing compiled Lisp code, known as @dfn{byte code}. +An object containing compiled Lisp code, known as @dfn{byte code}. @item subr -An object describing a Lisp primitive. +A Lisp primitive, i.e. a Lisp-callable function implemented in C. @end table @cindex closure - Note that there is no basic ``function'' type, as in more powerful +Note that there is no basic ``function'' type, as in more powerful versions of Lisp (where it's called a @dfn{closure}). XEmacs Lisp does not provide the closure semantics implemented by Common Lisp and Scheme. The guts of a function in XEmacs Lisp are represented in one of four ways: a symbol specifying another function (when one function is an -alias for another), a list containing the function's source code, a -bytecode object, or a subr object. (In other words, given a symbol -specifying the name of a function, calling @code{symbol-function} to -retrieve the contents of the symbol's function cell will return one of -these types of objects.) +alias for another), a list (whose first element must be the symbol +@code{lambda}) containing the function's source code, a +compiled-function object, or a subr object. (In other words, given a +symbol specifying the name of a function, calling @code{symbol-function} +to retrieve the contents of the symbol's function cell will return one +of these types of objects.) - XEmacs Lisp also contains numerous specialized objects used to -implement the editor: +XEmacs Lisp also contains numerous specialized objects used to implement +the editor: @table @code @item buffer @@ -1264,8 +1304,8 @@ An object representing a screen on which frames can be displayed; equivalent to a @dfn{display} in the X Window System and a @dfn{TTY} in character mode. @item face -An object specifying the appearance of text or graphics; it contains -characteristics such as font, foreground color, and background color. +An object specifying the appearance of text or graphics; it has +properties such as font, foreground color, and background color. @item marker An object that refers to a particular position in a buffer and moves around as text is inserted and deleted to stay in the same relative @@ -1297,11 +1337,11 @@ An object that describes a connection to an externally-running process. There are some other, less-commonly-encountered general objects: @table @code -@item hashtable +@item hash-table An object that maps from an arbitrary Lisp object to another arbitrary Lisp object, using hashing for fast lookup. @item obarray -A limited form of hashtable that maps from strings to symbols; obarrays +A limited form of hash-table that maps from strings to symbols; obarrays are used to look up a symbol given its name and are not actually their own object type but are kludgily represented using vectors with hidden fields (this representation derives from GNU Emacs). @@ -1343,14 +1383,11 @@ Objects that represent resources used in the ToolTalk interprocess communication protocol. @item toolbar-button An object used in conjunction with the toolbar. -@item x-resource -An object that encapsulates certain miscellaneous resources in the X -window system, used only when Epoch support is enabled. @end table And objects that are only used internally: -@table @asis +@table @code @item opaque A generic object for encapsulating arbitrary memory; this allows you the generality of @code{malloc()} and the convenience of the Lisp object @@ -1435,7 +1472,7 @@ converts to a char that represents the lowercase letter b. (where @samp{^[} actually is an @samp{ESC} character) converts to a particular Kanji character when using an ISO2022-based coding system for -input. (To decode this gook: @samp{ESC} begins an escape sequence; +input. (To decode this goo: @samp{ESC} begins an escape sequence; @samp{ESC $ (} is a class of escape sequences meaning ``switch to a 94x94 character set''; @samp{ESC $ ( B} means ``switch to Japanese Kanji''; @samp{#} and @samp{&} collectively index into a 94-by-94 array @@ -1462,7 +1499,7 @@ looking up the string equivalent in the global variable @code{obarray}, whose contents should be an obarray. If no symbol is found, a new symbol with the name @code{"foobar"} is automatically created and added to @code{obarray}; this process is called -@dfn{interning} the symbol. +@dfn{interning} the symbol. @cindex interning @example @@ -1500,6 +1537,12 @@ shown since they are not relevant here; look at a file that ends with converts to a bit-vector. @example +#s(hash-table ... ...) +@end example + +converts to a hash table (the actual contents are not shown). + +@example #s(range-table ... ...) @end example @@ -1510,25 +1553,26 @@ converts to a range table (the actual contents are not shown). @end example converts to a char table (the actual contents are not shown). -(Note that the #s syntax is the general syntax for structures, -which are not really implemented in XEmacs Lisp but should be.) - When an object is printed out (using @code{print} or a related +Note that the @code{#s()} syntax is the general syntax for structures, +which are not really implemented in XEmacs Lisp but should be. + +When an object is printed out (using @code{print} or a related function), the read syntax is used, so that the same object can be read in again. - The other objects do not have read syntaxes, usually because it does -not really make sense to create them in this fashion (i.e. processes, -where it doesn't make sense to have a subprocess created as a side -effect of reading some Lisp code), or because they can't be created at -all (e.g. subrs). Permanent objects, as a rule, do not have a read -syntax; nor do most complex objects, which contain too much state to be -easily initialized through a read syntax. +The other objects do not have read syntaxes, usually because it does not +really make sense to create them in this fashion (i.e. processes, where +it doesn't make sense to have a subprocess created as a side effect of +reading some Lisp code), or because they can't be created at all +(e.g. subrs). Permanent objects, as a rule, do not have a read syntax; +nor do most complex objects, which contain too much state to be easily +initialized through a read syntax. @node How Lisp Objects Are Represented in C, Rules When Writing New C Code, The XEmacs Object System (Abstractly Speaking), Top @chapter How Lisp Objects Are Represented in C - Lisp objects are represented in C using a 32- or 64-bit machine word +Lisp objects are represented in C using a 32-bit or 64-bit machine word (depending on the processor; i.e. DEC Alphas use 64-bit Lisp objects and most other processors use 32-bit Lisp objects). The representation stuffs a pointer together with a tag, as follows: @@ -1537,33 +1581,31 @@ stuffs a pointer together with a tag, as follows: [ 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 ] [ 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 ] - ^ <---> <------------------------------------------------------> - | tag a pointer to a structure, or an integer - | - `---> mark bit + <---> ^ <------------------------------------------------------> + tag | a pointer to a structure, or an integer + | + mark bit @end example - The tag describes the type of the Lisp object. For integers and -chars, the lower 28 bits contain the value of the integer or char; for -all others, the lower 28 bits contain a pointer. The mark bit is used +The tag describes the type of the Lisp object. For integers and chars, +the lower 28 bits contain the value of the integer or char; for all +others, the lower 28 bits contain a pointer. The mark bit is used during garbage-collection, and is always 0 when garbage collection is -not happening. Many macros that extract out parts of a Lisp object -expect that the mark bit is 0, and will produce incorrect results if -it's not. (The way that garbage collection works, basically, is that it +not happening. (The way that garbage collection works, basically, is that it loops over all places where Lisp objects could exist -- this includes all global variables in C that contain Lisp objects [including @code{Vobarray}, the C equivalent of @code{obarray}; through this, all Lisp variables will get marked], plus various other places -- and recursively scans through the Lisp objects, marking each object it finds by setting the mark bit. Then it goes through the lists of all objects -allocated, freeing the ones that are not marked and turning off the -mark bit of the ones that are marked.) +allocated, freeing the ones that are not marked and turning off the mark +bit of the ones that are marked.) - Lisp objects use the typedef @code{Lisp_Object}, but the actual C type +Lisp objects use the typedef @code{Lisp_Object}, but the actual C type used for the Lisp object can vary. It can be either a simple type (@code{long} on the DEC Alpha, @code{int} on other machines) or a structure whose fields are bit fields that line up properly (actually, a -union of structures that's used). Generally the simple integral type is +union of structures is used). Generally the simple integral type is preferable because it ensures that the compiler will actually use a machine word to represent the object (some compilers will use more general and less efficient code for unions and structs even if they can @@ -1571,27 +1613,28 @@ fit in a machine word). The union type, however, has the advantage of stricter type checking (if you accidentally pass an integer where a Lisp object is desired, you get a compile error), and it makes it easier to decode Lisp objects when debugging. The choice of which type to use is -determined by the presence or absence of the preprocessor constant -@code{USE_UNION_TYPE}. +determined by the preprocessor constant @code{USE_UNION_TYPE} which is +defined via the @code{--use-union-type} option to @code{configure}. @cindex record type - Note that there are only eight types that the tag can represent, -but many more actual types than this. This is handled by having -one of the tag types specify a meta-type called a @dfn{record}; -for all such objects, the first four bytes of the pointed-to -structure indicate what the actual type is. - - Note also that having 28 bits for pointers and integers restricts a -lot of things to 256 megabytes of memory. (Basically, enough pointers -and indices and whatnot get stuffed into Lisp objects that the total -amount of memory used by XEmacs can't grow above 256 megabytes. In -older versions of XEmacs and GNU Emacs, the tag was 5 bits wide, -allowing for 32 types, which was more than the actual number of types -that existed at the time, and no ``record'' type was necessary. -However, this limited the editor to 64 megabytes total, which some users -who edited large files might conceivably exceed.) - - Also, note that there is an implicit assumption here that all pointers + +Note that there are only eight types that the tag can represent, but +many more actual types than this. This is handled by having one of the +tag types specify a meta-type called a @dfn{record}; for all such +objects, the first four bytes of the pointed-to structure indicate what +the actual type is. + +Note also that having 28 bits for pointers and integers restricts a lot +of things to 256 megabytes of memory. (Basically, enough pointers and +indices and whatnot get stuffed into Lisp objects that the total amount +of memory used by XEmacs can't grow above 256 megabytes. In older +versions of XEmacs and GNU Emacs, the tag was 5 bits wide, allowing for +32 types, which was more than the actual number of types that existed at +the time, and no ``record'' type was necessary. However, this limited +the editor to 64 megabytes total, which some users who edited large +files might conceivably exceed.) + +Also, note that there is an implicit assumption here that all pointers are low enough that the top bits are all zero and can just be chopped off. On standard machines that allocate memory from the bottom up (and give each process its own address space), this works fine. Some @@ -1601,13 +1644,56 @@ machines, however, put the data space somewhere else in memory the proper mask. Then, pointers retrieved from Lisp objects are automatically OR'ed with this value prior to being used. - A corollary of the previous paragraph is that @strong{(pointers to) +A corollary of the previous paragraph is that @strong{(pointers to) stack-allocated structures cannot be put into Lisp objects}. The stack is generally located near the top of memory; if you put such a pointer into a Lisp object, it will get its top bits chopped off, and you will lose. - Various macros are used to construct Lisp objects and extract the +Actually, there's an alternative representation of a @code{Lisp_Object}, +invented by Kyle Jones, that is used when the +@code{--use-minimal-tagbits} option to @code{configure} is used. In +this case the 2 lower bits are used for the tag bits. This +representation assumes that pointers to structs are always aligned to +multiples of 4, so the lower 2 bits are always zero. + +@example + [ 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 ] + [ 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 ] + + <---------------------------------------------------------> <-> + a pointer to a structure, or an integer tag +@end example + +A tag of 00 is used for all pointer object types, a tag of 10 is used +for characters, and the other two tags 01 and 11 are joined together to +form the integer object type. The markbit is moved to part of the +structure being pointed at (integers and chars do not need to be marked, +since no memory is allocated). This representation has these +advantages: + +@enumerate +@item +31 bits can be used for Lisp Integers. +@item +@emph{Any} pointer can be represented directly, and no bit masking +operations are necessary. +@end enumerate + +The disadvantages are: + +@enumerate +@item +An extra level of indirection is needed when accessing the object types +that were not record types. So checking whether a Lisp object is a cons +cell becomes a slower operation. +@item +Mark bits can no longer be stored directly in Lisp objects, so another +place for them must be found. This means that a cons cell requires more +memory than merely room for 2 lisp objects, leading to extra memory use. +@end enumerate + +Various macros are used to construct Lisp objects and extract the components. Macros of the form @code{XINT()}, @code{XCHAR()}, @code{XSTRING()}, @code{XSYMBOL()}, etc. mask out the pointer/integer field and cast it to the appropriate type. All of the macros that @@ -1622,7 +1708,7 @@ machines/compilers do this, and on the ones that don't, a more complicated definition is selected by defining @code{EXPLICIT_SIGN_EXTEND}. - Note that when @code{ERROR_CHECK_TYPECHECK} is defined, the extractor +Note that when @code{ERROR_CHECK_TYPECHECK} is defined, the extractor macros become more complicated -- they check the tag bits and/or the type field in the first four bytes of a record type to ensure that the object is really of the correct type. This is great for catching places @@ -1630,8 +1716,9 @@ where an incorrect type is being dereferenced -- this typically results in a pointer being dereferenced as the wrong type of structure, with unpredictable (and sometimes not easily traceable) results. - There are similar @code{XSET@var{TYPE}()} macros that construct a Lisp object. -These macros are of the form @code{XSET@var{TYPE} (@var{lvalue}, @var{result})}, +There are similar @code{XSET@var{TYPE}()} macros that construct a Lisp +object. These macros are of the form @code{XSET@var{TYPE} +(@var{lvalue}, @var{result})}, i.e. they have to be a statement rather than just used in an expression. The reason for this is that standard C doesn't let you ``construct'' a structure (but GCC does). Granted, this sometimes isn't too convenient; @@ -1642,15 +1729,24 @@ affected by @code{ERROR_CHECK_TYPECHECK} and make sure that the structure is of the right type in the case of record types, where the type is contained in the structure. +The C programmer is responsible for @strong{guaranteeing} that a +Lisp_Object is is the correct type before using the @code{X@var{TYPE}} +macros. This is especially important in the case of lists. Use +@code{XCAR} and @code{XCDR} if a Lisp_Object is certainly a cons cell, +else use @code{Fcar()} and @code{Fcdr()}. Trust other C code, but not +Lisp code. On the other hand, if XEmacs has an internal logic error, +it's better to crash immediately, so sprinkle ``unreachable'' +@code{abort()}s liberally about the source code. + @node Rules When Writing New C Code, A Summary of the Various XEmacs Modules, How Lisp Objects Are Represented in C, Top @chapter Rules When Writing New C Code - The XEmacs C Code is extremely complex and intricate, and there are -many rules that are more or less consistently followed throughout the code. +The XEmacs C Code is extremely complex and intricate, and there are many +rules that are more or less consistently followed throughout the code. Many of these rules are not obvious, so they are explained here. It is -of the utmost importance that you follow them. If you don't, you may get -something that appears to work, but which will crash in odd situations, -often in code far away from where the actual breakage is. +of the utmost importance that you follow them. If you don't, you may +get something that appears to work, but which will crash in odd +situations, often in code far away from where the actual breakage is. @menu * General Coding Rules:: @@ -1663,7 +1759,15 @@ often in code far away from where the actual breakage is. @node General Coding Rules @section General Coding Rules - Almost every module contains a @code{syms_of_*()} function and a +The C code is actually written in a dialect of C called @dfn{Clean C}, +meaning that it can be compiled, mostly warning-free, with either a C or +C++ compiler. Coding in Clean C has several advantages over plain C. +C++ compilers are more nit-picking, and a number of coding errors have +been found by compiling with C++. The ability to use both C and C++ +tools means that a greater variety of development tools are available to +the developer. + +Almost every module contains a @code{syms_of_*()} function and a @code{vars_of_*()} function. The former declares any Lisp primitives you have defined and defines any symbols you will be using. The latter declares any global Lisp variables you have added and initializes global @@ -1678,16 +1782,16 @@ a @code{complex_vars_of_*()} function for it. Doing this is tricky, though: You have to make sure your function is called at the right time so that all the initialization dependencies work out. - Every module includes @file{} (angle brackets so that +Every module includes @file{} (angle brackets so that @samp{--srcdir} works correctly; @file{config.h} may or may not be in the same directory as the C sources) and @file{lisp.h}. @file{config.h} -should always be included before any other header files (including +must always be included before any other header files (including system header files) to ensure that certain tricks played by various @file{s/} and @file{m/} files work out correctly. - @strong{All global and static variables that are to be modifiable must -be declared uninitialized.} This means that you may not use the ``declare -with initializer'' form for these variables, such as @code{int +@strong{All global and static variables that are to be modifiable must +be declared uninitialized.} This means that you may not use the +``declare with initializer'' form for these variables, such as @code{int some_variable = 0;}. The reason for this has to do with some kludges done during the dumping process: If possible, the initialized data segment is re-mapped so that it becomes part of the (unmodifiable) code @@ -1698,22 +1802,22 @@ particular, into what's called the @dfn{pure space} -- see below) during the @file{temacs} phase. @cindex copy-on-write - @strong{Please note:} This kludge only works on a few systems -nowadays, and is rapidly becoming irrelevant because most modern -operating systems provide @dfn{copy-on-write} semantics. All data is -initially shared between processes, and a private copy is automatically -made (on a page-by-page basis) when a process first attempts to write to -a page of memory. - - Formerly, there was a requirement that static variables not be -declared inside of functions. This had to do with another hack along -the same vein as what was just described: old USG systems put -statically-declared variables in the initialized data space, so those -header files had a @code{#define static} declaration. (That way, the -data-segment remapping described above could still work.) This fails -badly on static variables inside of functions, which suddenly become -automatic variables; therefore, you weren't supposed to have any of -them. This awful kludge has been removed in XEmacs because +@strong{Please note:} This kludge only works on a few systems nowadays, +and is rapidly becoming irrelevant because most modern operating systems +provide @dfn{copy-on-write} semantics. All data is initially shared +between processes, and a private copy is automatically made (on a +page-by-page basis) when a process first attempts to write to a page of +memory. + +Formerly, there was a requirement that static variables not be declared +inside of functions. This had to do with another hack along the same +vein as what was just described: old USG systems put statically-declared +variables in the initialized data space, so those header files had a +@code{#define static} declaration. (That way, the data-segment remapping +described above could still work.) This fails badly on static variables +inside of functions, which suddenly become automatic variables; +therefore, you weren't supposed to have any of them. This awful kludge +has been removed in XEmacs because @enumerate @item @@ -1725,41 +1829,72 @@ the only systems that didn't were extremely outdated ones; this hack completely messed up inline functions. @end enumerate +The C source code makes heavy use of C preprocessor macros. One popular +macro style is: + +@example +#define FOO(var, value) do @{ \ + Lisp_Object FOO_value = (value); \ + ... /* compute using FOO_value */ \ + (var) = bar; \ +@} while (0) +@end example + +The @code{do @{...@} while (0)} is a standard trick to allow FOO to have +statement semantics, so that it can safely be used within an @code{if} +statement in C, for example. Multiple evaluation is prevented by +copying a supplied argument into a local variable, so that +@code{FOO(var,fun(1))} only calls @code{fun} once. + +Lisp lists are popular data structures in the C code as well as in +Elisp. There are two sets of macros that iterate over lists. +@code{EXTERNAL_LIST_LOOP_@var{n}} should be used when the list has been +supplied by the user, and cannot be trusted to be acyclic and +nil-terminated. A @code{malformed-list} or @code{circular-list} error +will be generated if the list being iterated over is not entirely +kosher. @code{LIST_LOOP_@var{n}}, on the other hand, is faster and less +safe, and can be used only on trusted lists. + +Related macros are @code{GET_EXTERNAL_LIST_LENGTH} and +@code{GET_LIST_LENGTH}, which calculate the length of a list, and in the +case of @code{GET_EXTERNAL_LIST_LENGTH}, validating the properness of +the list. The macros @code{EXTERNAL_LIST_LOOP_DELETE_IF} and +@code{LIST_LOOP_DELETE_IF} delete elements from a lisp list satisfying some +predicate. + @node Writing Lisp Primitives @section Writing Lisp Primitives - Lisp primitives are Lisp functions implemented in C. The details of +Lisp primitives are Lisp functions implemented in C. The details of interfacing the C function so that Lisp can call it are handled by a few C macros. The only way to really understand how to write new C code is to read the source, but we can explain some things here. - An example of a special form is the definition of @code{or}, from +An example of a special form is the definition of @code{prog1}, from @file{eval.c}. (An ordinary function would have the same general appearance.) @cindex garbage collection protection @smallexample @group -DEFUN ("or", For, 0, UNEVALLED, 0, /* -Eval args until one of them yields non-nil, then return that value. -The remaining args are not evalled at all. -If all args return nil, return nil. +DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* +Similar to `progn', but the value of the first form is returned. +\(prog1 FIRST BODY...): All the arguments are evaluated sequentially. +The value of FIRST is saved during evaluation of the remaining args, +whose values are discarded. */ (args)) @{ /* This function can GC */ - Lisp_Object val = Qnil; + REGISTER Lisp_Object val, form, tail; struct gcpro gcpro1; - GCPRO1 (args); + val = Feval (XCAR (args)); - while (!NILP (args)) - @{ - val = Feval (XCAR (args)); - if (!NILP (val)) - break; - args = XCDR (args); - @} + GCPRO1 (val); + + LIST_LOOP_3 (form, XCDR (args), tail) + Feval (form); UNGCPRO; return val; @@ -1771,23 +1906,25 @@ If all args return nil, return nil. @code{DEFUN} macro. Here is a template for them: @example -DEFUN (@var{lname}, @var{fname}, @var{min}, @var{max}, @var{interactive}, /* -@var{docstring} -*/ - (@var{arglist}) ) +@group +DEFUN (@var{lname}, @var{fname}, @var{min_args}, @var{max_args}, @var{interactive}, /* +@var{docstring} +*/ + (@var{arglist})) +@end group @end example @table @var @item lname This string is the name of the Lisp symbol to define as the function -name; in the example above, it is @code{"or"}. +name; in the example above, it is @code{"prog1"}. @item fname This is the C function name for this function. This is the name that is used in C code for calling the function. The name is, by convention, @samp{F} prepended to the Lisp name, with all dashes (@samp{-}) in the Lisp name changed to underscores. Thus, to call this function from C -code, call @code{For}. Remember that the arguments are of type +code, call @code{Fprog1}. Remember that the arguments are of type @code{Lisp_Object}; various macros and functions for creating values of type @code{Lisp_Object} are declared in the file @file{lisp.h}. @@ -1804,31 +1941,32 @@ conveys the Lisp symbol name to the initialization routine that will create the symbol and store the subr object as its definition. The C variable name of this structure is always @samp{S} prepended to the @var{fname}. You hardly ever need to be aware of the existence of this -structure. +structure, since @code{DEFUN} plus @code{DEFSUBR} takes care of all the +details. -@item min +@item min_args This is the minimum number of arguments that the function requires. The -function @code{or} allows a minimum of zero arguments. +function @code{prog1} allows a minimum of one argument. -@item max +@item max_args This is the maximum number of arguments that the function accepts, if there is a fixed maximum. Alternatively, it can be @code{UNEVALLED}, indicating a special form that receives unevaluated arguments, or @code{MANY}, indicating an unlimited number of evaluated arguments (the -equivalent of @code{&rest}). Both @code{UNEVALLED} and @code{MANY} are -macros. If @var{max} is a number, it may not be less than @var{min} and -it may not be greater than 8. (If you need to add a function with -more than 8 arguments, either use the @code{MANY} form or edit the -definition of @code{DEFUN} in @file{lisp.h}. If you do the latter, -make sure to also add another clause to the switch statement in -@code{primitive_funcall().}) +C equivalent of @code{&rest}). Both @code{UNEVALLED} and @code{MANY} +are macros. If @var{max_args} is a number, it may not be less than +@var{min_args} and it may not be greater than 8. (If you need to add a +function with more than 8 arguments, use the @code{MANY} form. Resist +the urge to edit the definition of @code{DEFUN} in @file{lisp.h}. If +you do it anyways, make sure to also add another clause to the switch +statement in @code{primitive_funcall().}) @item interactive This is an interactive specification, a string such as might be used as the argument of @code{interactive} in a Lisp function. In the case of -@code{or}, it is 0 (a null pointer), indicating that @code{or} cannot be -called interactively. A value of @code{""} indicates a function that -should receive no arguments when called interactively. +@code{prog1}, it is 0 (a null pointer), indicating that @code{prog1} +cannot be called interactively. A value of @code{""} indicates a +function that should receive no arguments when called interactively. @item docstring This is the documentation string. It is written just like a @@ -1841,18 +1979,18 @@ specification. @file{make-docfile}, which scans the C files for documentation strings, is very particular about what it looks for, and will not properly extract the doc string if it's not in this exact format. -You are free to put the various arguments to @code{DEFUN} on separate -lines to avoid overly long lines. However, make sure to put the -comment-start characters for the doc string on the same line as the -interactive specification, and put a newline directly after them (and -before the comment-end characters). +In order to make both @file{etags} and @file{make-docfile} happy, make +sure that the @code{DEFUN} line contains the @var{lname} and +@var{fname}, and that the comment-start characters for the doc string +are on the same line as the interactive specification, and put a newline +directly after them (and before the comment-end characters). @item arglist This is the comma-separated list of arguments to the C function. For a function with a fixed maximum number of arguments, provide a C argument for each Lisp argument. In this case, unlike regular C functions, the types of the arguments are not declared; they are simply always of type -@code{Lisp_Object}. +@code{Lisp_Object}. The names of the C arguments will be used as the names of the arguments to the Lisp primitive as displayed in its documentation, modulo the same @@ -1865,13 +2003,13 @@ reserved words (like @code{default}) or global symbols (like @code{dirname}) to be used as argument names without compiler warnings or errors. -A Lisp function with @w{@var{max} = @code{UNEVALLED}} is a +A Lisp function with @w{@var{max_args} = @code{UNEVALLED}} is a @w{@dfn{special form}}; its arguments are not evaluated. Instead it receives one argument of type @code{Lisp_Object}, a (Lisp) list of the unevaluated arguments, conventionally named @code{(args)}. When a Lisp function has no upper limit on the number of arguments, -specify @w{@var{max} = @code{MANY}}. In this case its implementation in +specify @w{@var{max_args} = @code{MANY}}. In this case its implementation in C actually receives exactly two arguments: the number of Lisp arguments (an @code{int}) and the address of a block containing their values (a @w{@code{Lisp_Object *}}). In this case only are the C types specified @@ -1879,52 +2017,56 @@ in the @var{arglist}: @w{@code{(int nargs, Lisp_Object *args)}}. @end table - Within the function @code{For} itself, note the use of the macros +Within the function @code{Fprog1} itself, note the use of the macros @code{GCPRO1} and @code{UNGCPRO}. @code{GCPRO1} is used to ``protect'' a variable from garbage collection---to inform the garbage collector -that it must look in that variable and regard its contents as an -accessible object. This is necessary whenever you call @code{Feval} or -anything that can directly or indirectly call @code{Feval} (this -includes the @code{QUIT} macro!). At such a time, any Lisp object that -you intend to refer to again must be protected somehow. @code{UNGCPRO} -cancels the protection of the variables that are protected in the -current function. It is necessary to do this explicitly. - - The macro @code{GCPRO1} protects just one local variable. If you want +that it must look in that variable and regard the object pointed at by +its contents as an accessible object. This is necessary whenever you +call @code{Feval} or anything that can directly or indirectly call +@code{Feval} (this includes the @code{QUIT} macro!). At such a time, +any Lisp object that you intend to refer to again must be protected +somehow. @code{UNGCPRO} cancels the protection of the variables that +are protected in the current function. It is necessary to do this +explicitly. + +The macro @code{GCPRO1} protects just one local variable. If you want to protect two, use @code{GCPRO2} instead; repeating @code{GCPRO1} will not work. Macros @code{GCPRO3} and @code{GCPRO4} also exist. - These macros implicitly use local variables such as @code{gcpro1}; you +These macros implicitly use local variables such as @code{gcpro1}; you must declare these explicitly, with type @code{struct gcpro}. Thus, if you use @code{GCPRO2}, you must declare @code{gcpro1} and @code{gcpro2}. @cindex caller-protects (@code{GCPRO} rule) - Note also that the general rule is @dfn{caller-protects}; i.e. you -are only responsible for protecting those Lisp objects that you create. -Any objects passed to you as parameters should have been protected -by whoever created them, so you don't in general have to protect them. -@code{For} is an exception; it protects its parameters to provide -extra assurance against Lisp primitives elsewhere that are incorrectly -written, and against malicious self-modifying code. There are a few -other standard functions that also do this. - -@code{GCPRO}ing is perhaps the trickiest and most error-prone part -of XEmacs coding. It is @strong{extremely} important that you get this +Note also that the general rule is @dfn{caller-protects}; i.e. you are +only responsible for protecting those Lisp objects that you create. Any +objects passed to you as arguments should have been protected by whoever +created them, so you don't in general have to protect them. + +In particular, the arguments to any Lisp primitive are always +automatically @code{GCPRO}ed, when called ``normally'' from Lisp code or +bytecode. So only a few Lisp primitives that are called frequently from +C code, such as @code{Fprogn} protect their arguments as a service to +their caller. You don't need to protect your arguments when writing a +new @code{DEFUN}. + +@code{GCPRO}ing is perhaps the trickiest and most error-prone part of +XEmacs coding. It is @strong{extremely} important that you get this right and use a great deal of discipline when writing this code. @xref{GCPROing, ,@code{GCPRO}ing}, for full details on how to do this. - What @code{DEFUN} actually does is declare a global structure of -type @code{Lisp_Subr} whose name begins with capital @samp{SF} and -which contains information about the primitive (e.g. a pointer to the +What @code{DEFUN} actually does is declare a global structure of type +@code{Lisp_Subr} whose name begins with capital @samp{SF} and which +contains information about the primitive (e.g. a pointer to the function, its minimum and maximum allowed arguments, a string describing -its Lisp name); @code{DEFUN} then begins a normal C function -declaration using the @code{F...} name. The Lisp subr object that is -the function definition of a primitive (i.e. the object in the function -slot of the symbol that names the primitive) actually points to this -@samp{SF} structure; when @code{Feval} encounters a subr, it looks in the +its Lisp name); @code{DEFUN} then begins a normal C function declaration +using the @code{F...} name. The Lisp subr object that is the function +definition of a primitive (i.e. the object in the function slot of the +symbol that names the primitive) actually points to this @samp{SF} +structure; when @code{Feval} encounters a subr, it looks in the structure to find out how to call the C function. - Defining the C function is not enough to make a Lisp primitive +Defining the C function is not enough to make a Lisp primitive available; you must also create the Lisp symbol for the primitive (the symbol is @dfn{interned}; @pxref{Obarrays}) and store a suitable subr object in its function cell. (If you don't do this, the primitive won't @@ -1934,17 +2076,16 @@ be seen by Lisp code.) The code looks like this: DEFSUBR (@var{fname}); @end example -@noindent -Here @var{fname} is the name you used as the second argument to +@noindent +Here @var{fname} is the same name you used as the second argument to @code{DEFUN}. - This call to @code{DEFSUBR} should go in the @code{syms_of_*()} -function at the end of the module. If no such function exists, create -it and make sure to also declare it in @file{symsinit.h} and call it -from the appropriate spot in @code{main()}. @xref{General Coding -Rules}. +This call to @code{DEFSUBR} should go in the @code{syms_of_*()} function +at the end of the module. If no such function exists, create it and +make sure to also declare it in @file{symsinit.h} and call it from the +appropriate spot in @code{main()}. @xref{General Coding Rules}. - Note that C code cannot call functions by name unless they are defined +Note that C code cannot call functions by name unless they are defined in C. The way to call a function written in Lisp from C is to use @code{Ffuncall}, which embodies the Lisp function @code{funcall}. Since the Lisp function @code{funcall} accepts an unlimited number of @@ -1954,21 +2095,21 @@ argument is the Lisp function to call, and the rest are the arguments to pass to it. Since @code{Ffuncall} can call the evaluator, you must protect pointers from garbage collection around the call to @code{Ffuncall}. (However, @code{Ffuncall} explicitly protects all of -its parameters, so you don't have to protect any pointers passed -as parameters to it.) +its parameters, so you don't have to protect any pointers passed as +parameters to it.) - The C functions @code{call0}, @code{call1}, @code{call2}, and so on, +The C functions @code{call0}, @code{call1}, @code{call2}, and so on, provide handy ways to call a Lisp function conveniently with a fixed number of arguments. They work by calling @code{Ffuncall}. - @file{eval.c} is a very good file to look through for examples; -@file{lisp.h} contains the definitions for some important macros and +@file{eval.c} is a very good file to look through for examples; +@file{lisp.h} contains the definitions for important macros and functions. @node Adding Global Lisp Variables @section Adding Global Lisp Variables - Global variables whose names begin with @samp{Q} are constants whose +Global variables whose names begin with @samp{Q} are constants whose value is a symbol of a particular name. The name of the variable should be derived from the name of the symbol using the same rules as for Lisp primitives. These variables are initialized using a call to @@ -2149,13 +2290,13 @@ For instance: ... @{ /* Allocate place for @var{cclen} characters. */ - Bufbyte *tmp_buf = (Bufbyte *)alloca (cclen * MAX_EMCHAR_LEN); + Bufbyte *buf = (Bufbyte *)alloca (cclen * MAX_EMCHAR_LEN); ... @end group @end example If you followed the previous section, you can guess that, logically, -multiplying a @code{Charcount} value with @code{MAX_EMCHAR_LEN} produces +multiplying a @code{Charcount} value with @code{MAX_EMCHAR_LEN} produces a @code{Bytecount} value. In the current Mule implementation, @code{MAX_EMCHAR_LEN} equals 4. @@ -2256,7 +2397,7 @@ When an external function, such as a C library function, returns a This is because these returned strings may contain 8bit characters which can be misinterpreted by XEmacs, and cause a crash. Likewise, when exporting a piece of internal text to the outside world, you should -always convert it to an appropriate external encoding, lest the internal +always convert it to an appropriate external encoding, lest the internal stuff (such as the infamous \201 characters) leak out. The interface to conversion between the internal and external @@ -2265,7 +2406,7 @@ representations of text are the numerous conversion macros defined in formats supported by these macros. Currently meaningful formats are @code{FORMAT_BINARY}, -@code{FORMAT_FILENAME}, @code{FORMAT_OS}, and @code{FORMAT_CTEXT}. Here +@code{FORMAT_FILENAME}, @code{FORMAT_OS}, and @code{FORMAT_CTEXT}. Here is a description of these. @table @code @@ -2299,7 +2440,7 @@ stored in properties, selections, and the like. This is an 8-bit no-lock-shift ISO2022 coding system. @end table -The macros to convert between these formats and the internal format, and +The macros to convert between these formats and the internal format, and vice versa, follow. @table @code @@ -2379,13 +2520,13 @@ through the internal text, use @code{Bufbyte *}. Also note that you almost certainly do not need @code{Emchar *}. @item Be careful not to confuse @code{Charcount}, @code{Bytecount}, and @code{Bufpos}. -The whole point of using different types is to avoid confusion about the -use of certain variables. Lest this effect be nullified, you need to be +The whole point of using different types is to avoid confusion about the +use of certain variables. Lest this effect be nullified, you need to be careful about using the right types. @item Always convert external data It is extremely important to always convert external data, because -XEmacs can crash if unexpected 8bit sequences are copied to its internal +XEmacs can crash if unexpected 8bit sequences are copied to its internal buffers literally. This means that when a system function, such as @code{readdir}, returns @@ -2446,8 +2587,8 @@ extracts the @code{Emchar} from the @code{Lisp_Object}, and @code{set_charptr_emchar} stores it to storage, increasing @code{p} in the process. -Other instructing examples of correct coding under Mule can be found all -over XEmacs code. For starters, I recommend +Other instructive examples of correct coding under Mule can be found all +over the XEmacs code. For starters, I recommend @code{Fnormalize_menu_item_name} in @file{menubar.c}. After you have understood this section of the manual and studied the examples, you can proceed writing new Mule-aware code. @@ -2458,7 +2599,7 @@ proceed writing new Mule-aware code. To make a quantified XEmacs, do: @code{make quantmacs}. You simply can't dump Quantified and Purified images. Run the image -like so: @code{quantmacs -batch -l loadup.el run-temacs -q}. +like so: @code{quantmacs -batch -l loadup.el run-temacs @var{xemacs-args...}}. Before you go through the trouble, are you compiling with all debugging and error-checking off? If not try that first. Be warned @@ -2475,46 +2616,85 @@ to throw most results off). It also enables three additional elisp commands: @code{quantify-start-recording-data}, @code{quantify-stop-recording-data} and @code{quantify-clear-data}. +If you want to make XEmacs faster, target your favorite slow benchmark, +run a profiler like Quantify, @code{gprof}, or @code{tcov}, and figure +out where the cycles are going. Specific projects: + +@itemize @bullet +@item +Make the garbage collector faster. Figure out how to write an +incremental garbage collector. +@item +Write a compiler that takes bytecode and spits out C code. +Unfortunately, you will then need a C compiler and a more fully +developed module system. +@item +Speed up redisplay. +@item +Speed up syntax highlighting. Maybe moving some of the syntax +highlighting capabilities into C would make a difference. +@item +Implement tail recursion in Emacs Lisp (hard!). +@end itemize + +Unfortunately, Emacs Lisp is slow, and is going to stay slow. Function +calls in elisp are especially expensive. Iterating over a long list is +going to be 30 times faster implemented in C than in Elisp. + To get started debugging XEmacs, take a look at the @file{gdbinit} and -@file{dbxrc} files in the @file{src} directory. -@xref{Q2.1.15 - How to Debug an XEmacs problem with a debugger,,, +@file{dbxrc} files in the @file{src} directory. +@xref{Q2.1.15 - How to Debug an XEmacs problem with a debugger,,, xemacs-faq, XEmacs FAQ}. +After making source code changes, run @code{make check} to ensure that +you haven't introduced any regressions. If you're feeling ambitious, +you can try to improve the test suite in @file{tests/automated}. Here are things to know when you create a new source file: @itemize @bullet @item -All .c files should @code{#include } first. Almost all .c -files should @code{#include "lisp.h"} second. +All @file{.c} files should @code{#include } first. Almost all +@file{.c} files should @code{#include "lisp.h"} second. @item -Generated header files should be included using the @code{<>} syntax, -not the @code{""} syntax. The generated headers are: +Generated header files should be included using the @code{#include <...>} syntax, +not the @code{#include "..."} syntax. The generated headers are: -config.h puresize-adjust.h sheap-adjust.h paths.h Emacs.ad.h +@file{config.h puresize-adjust.h sheap-adjust.h paths.h Emacs.ad.h} The basic rule is that you should assume builds using @code{--srcdir} -and the @code{<>} syntax needs to be used when the to-be-included -generated file is in a potentially different directory -@emph{at compile time}. +and the @code{#include <...>} syntax needs to be used when the +to-be-included generated file is in a potentially different directory +@emph{at compile time}. The non-obvious C rule is that @code{#include "..."} +means to search for the included file in the same directory as the +including file, @emph{not} in the current directory. -@item -Header files should not include and "lisp.h". It is the -responsibility of the .c files that use it to do so. +@item +Header files should @emph{not} include @code{} and +@code{"lisp.h"}. It is the responsibility of the @file{.c} files that +use it to do so. -@item -If the header uses INLINE, either directly or though DECLARE_LRECORD, -then it must be added to inline.c's includes. +@item +If the header uses @code{INLINE}, either directly or though +@code{DECLARE_LRECORD}, then it must be added to @file{inline.c}'s +includes. @item -Try compiling at least once with +Try compiling at least once with @example gcc --with-mule --with-union-type --error-checking=all @end example + +@item +Did I mention that you should run the test suite? +@example +make check +@end example @end itemize + @node A Summary of the Various XEmacs Modules, Allocation of Objects in XEmacs Lisp, Rules When Writing New C Code, Top @chapter A Summary of the Various XEmacs Modules @@ -2539,9 +2719,7 @@ gcc --with-mule --with-union-type --error-checking=all @section Low-Level Modules @example - size name -------- --------------------- - 18150 config.h +config.h @end example This is automatically generated from @file{config.h.in} based on the @@ -2552,7 +2730,7 @@ environment in which XEmacs is being compiled. @example - 2347 paths.h +paths.h @end example This is automatically generated from @file{paths.h.in} based on supplied @@ -2562,8 +2740,8 @@ of the XEmacs directories. It's currently broken, though. @example - 47878 emacs.c - 20239 signal.c +emacs.c +signal.c @end example @file{emacs.c} contains @code{main()} and other code that performs the most @@ -2583,23 +2761,23 @@ dependencies in interfacing to signals; that is handled using the @example - 23458 unexaix.c - 9893 unexalpha.c - 11302 unexapollo.c - 16544 unexconvex.c - 31967 unexec.c - 30959 unexelf.c - 35791 unexelfsgi.c - 3207 unexencap.c - 7276 unexenix.c - 20539 unexfreebsd.c - 1153 unexfx2800.c - 13432 unexhp9k3.c - 11049 unexhp9k800.c - 9165 unexmips.c - 8981 unexnext.c - 1673 unexsol2.c - 19261 unexsunos4.c +unexaix.c +unexalpha.c +unexapollo.c +unexconvex.c +unexec.c +unexelf.c +unexelfsgi.c +unexencap.c +unexenix.c +unexfreebsd.c +unexfx2800.c +unexhp9k3.c +unexhp9k800.c +unexmips.c +unexnext.c +unexsol2.c +unexsunos4.c @end example These modules contain code dumping out the XEmacs executable on various @@ -2611,9 +2789,9 @@ chosen by @file{configure}. @example - 15715 crt0.c - 1484 lastfile.c - 1115 pre-crt0.c +crt0.c +lastfile.c +pre-crt0.c @end example These modules are used in conjunction with the dump mechanism. On some @@ -2638,14 +2816,14 @@ data space when dumping. @example - 14786 alloca.c - 16678 free-hook.c - 1692 getpagesize.h - 41936 gmalloc.c - 25141 malloc.c - 3802 mem-limits.h - 39011 ralloc.c - 3436 vm-limit.c +alloca.c +free-hook.c +getpagesize.h +gmalloc.c +malloc.c +mem-limits.h +ralloc.c +vm-limit.c @end example These handle basic C allocation of memory. @file{alloca.c} is an emulation of @@ -2663,20 +2841,21 @@ didn't work on some systems where @file{malloc.c} worked; but this should be fixed now.) @cindex relocating allocator -@file{ralloc.c} is the @dfn{relocating allocator}. It provides functions -similar to @code{malloc()}, @code{realloc()} and @code{free()} that allocate -memory that can be dynamically relocated in memory. The advantage of -this is that allocated memory can be shuffled around to place all the -free memory at the end of the heap, and the heap can then be shrunk, -releasing the memory back to the operating system. The use of this can -be controlled with the configure option @code{--rel-alloc}; if enabled, memory allocated for -buffers will be relocatable, so that if a very large file is visited and -the buffer is later killed, the memory can be released to the operating -system. (The disadvantage of this mechanism is that it can be very -slow. On systems with the @code{mmap()} system call, the XEmacs version -of @file{ralloc.c} uses this to move memory around without actually having to -block-copy it, which can speed things up; but it can still cause -noticeable performance degradation.) +@file{ralloc.c} is the @dfn{relocating allocator}. It provides +functions similar to @code{malloc()}, @code{realloc()} and @code{free()} +that allocate memory that can be dynamically relocated in memory. The +advantage of this is that allocated memory can be shuffled around to +place all the free memory at the end of the heap, and the heap can then +be shrunk, releasing the memory back to the operating system. The use +of this can be controlled with the configure option @code{--rel-alloc}; +if enabled, memory allocated for buffers will be relocatable, so that if +a very large file is visited and the buffer is later killed, the memory +can be released to the operating system. (The disadvantage of this +mechanism is that it can be very slow. On systems with the +@code{mmap()} system call, the XEmacs version of @file{ralloc.c} uses +this to move memory around without actually having to block-copy it, +which can speed things up; but it can still cause noticeable performance +degradation.) @file{free-hook.c} contains some debugging functions for checking for invalid arguments to @code{free()}. @@ -2693,10 +2872,9 @@ similar in spirit to the @file{sys*.h} files described in section J, below. @example - 2659 blocktype.c - 1410 blocktype.h - 7194 dynarr.c - 2671 dynarr.h +blocktype.c +blocktype.h +dynarr.c @end example These implement a couple of basic C data types to facilitate memory @@ -2720,7 +2898,7 @@ mechanism. @example - 2058 inline.c +inline.c @end example This module is used in connection with inline functions (available in @@ -2734,8 +2912,8 @@ function definitions, so that each one gets a real function equivalent. @example - 6489 debug.c - 2267 debug.h +debug.c +debug.h @end example These functions provide a system for doing internal consistency checks @@ -2746,7 +2924,7 @@ provided by the @samp{--error-check-*} configuration options. @example - 1643 prefix-args.c +prefix-args.c @end example This is actually the source for a small, self-contained program @@ -2754,7 +2932,7 @@ used during building. @example - 904 universe.h +universe.h @end example This is not currently used. @@ -2765,14 +2943,12 @@ This is not currently used. @section Basic Lisp Modules @example - size name -------- --------------------- - 70167 emacsfns.h - 6305 lisp-disunion.h - 7086 lisp-union.h - 54929 lisp.h - 14235 lrecord.h - 10728 symsinit.h +emacsfns.h +lisp-disunion.h +lisp-union.h +lisp.h +lrecord.h +symsinit.h @end example These are the basic header files for all XEmacs modules. Each module @@ -2792,7 +2968,7 @@ low-level macros. As a general rule, all typedefs should go into the typedefs section of @file{lisp.h} rather than into a module-specific header file even if the structure is defined elsewhere. This allows function prototypes that -use the typedef to be placed into @file{emacsfns.h}. Forward structure +use the typedef to placed into other header files. Forward structure declarations (i.e. a simple declaration like @code{struct foo;} where the structure itself is defined elsewhere) should be placed into the typedefs section as necessary. @@ -2802,20 +2978,22 @@ all record-type Lisp objects -- i.e. all objects whose type is a field in their C structure, which includes all objects except the few most basic ones. -@file{emacsfns.h} contains prototypes for most of the exported functions -in the various modules. (In particular, prototypes for Lisp primitives -should always go into this header file. Prototypes for other functions -can either go here or in a module-specific header file, depending on how -general-purpose the function is and whether it has special-purpose -argument types requiring definitions not in @file{lisp.h}.) All -initialization functions are prototyped in @file{symsinit.h}. +@file{lisp.h} contains prototypes for most of the exported functions in +the various modules. Lisp primitives defined using @code{DEFUN} that +need to be called by C code should be declared using @code{EXFUN}. +Other function prototypes should be placed either into the appropriate +section of @code{lisp.h}, or into a module-specific header file, +depending on how general-purpose the function is and whether it has +special-purpose argument types requiring definitions not in +@file{lisp.h}.) All initialization functions are prototyped in +@file{symsinit.h}. @example - 120478 alloc.c - 1029 pure.c - 2506 puresize.h +alloc.c +pure.c +puresize.h @end example The large module @file{alloc.c} implements all of the basic allocation and @@ -2872,8 +3050,8 @@ pure space is needed. @example - 122243 eval.c - 2305 backtrace.h +eval.c +backtrace.h @end example This module contains all of the functions to handle the flow of control. @@ -2892,7 +3070,7 @@ flow of control. @example - 64949 lread.c +lread.c @end example This module implements the Lisp reader and the @code{read} function, @@ -2903,7 +3081,7 @@ a part of all compilers. @example - 40900 print.c +print.c @end example This module implements the Lisp print mechanism and the @code{print} @@ -2915,9 +3093,9 @@ an equivalent object.) @example - 4518 general.c - 60220 symbols.c - 9966 symeval.h +general.c +symbols.c +symeval.h @end example @file{symbols.c} implements the handling of symbols, obarrays, and @@ -2935,9 +3113,9 @@ created, and those symbols are used everywhere throughout XEmacs. @example - 48973 data.c - 25694 floatfns.c - 71049 fns.c +data.c +floatfns.c +fns.c @end example These modules implement the methods and standard Lisp primitives for all @@ -2956,13 +3134,13 @@ arithmetic. @example - 23555 bytecode.c - 3358 bytecode.h +bytecode.c +bytecode.h @end example -@file{bytecode.c} implements the byte-code interpreter, and @file{bytecode.h} contains -associated structures. Note that the byte-code @emph{compiler} is -written in Lisp. +@file{bytecode.c} implements the byte-code interpreter and +compiled-function objects, and @file{bytecode.h} contains associated +structures. Note that the byte-code @emph{compiler} is written in Lisp. @@ -2971,11 +3149,9 @@ written in Lisp. @section Modules for Standard Editing Operations @example - size name -------- --------------------- - 82900 buffer.c - 60964 buffer.h - 6059 bufslots.h +buffer.c +buffer.h +bufslots.h @end example @file{buffer.c} implements the @dfn{buffer} Lisp object type. This @@ -3004,8 +3180,8 @@ the built-in buffer-local variables. @example - 79888 insdel.c - 6103 insdel.h +insdel.c +insdel.h @end example @file{insdel.c} contains low-level functions for inserting and deleting text in @@ -3019,7 +3195,7 @@ convert between byte offsets and character offsets. @example - 10975 marker.c +marker.c @end example This module implements the @dfn{marker} Lisp object type, which @@ -3038,8 +3214,8 @@ current buffer position of the marker. @example - 193714 extents.c - 15686 extents.h +extents.c +extents.h @end example This module implements the @dfn{extent} Lisp object type, which is like @@ -3059,7 +3235,7 @@ cover.) @example - 60155 editfns.c +editfns.c @end example @file{editfns.c} contains the standard Lisp primitives for working with @@ -3076,9 +3252,9 @@ this XEmacs process, etc. It's not clear why this code is in @example - 26081 callint.c - 12577 cmds.c - 2749 commands.h +callint.c +cmds.c +commands.h @end example @cindex interactive @@ -3105,9 +3281,9 @@ defined in @file{editfns.c}. @example - 194863 regex.c - 18968 regex.h - 79800 search.c +regex.c +regex.h +search.c @end example @file{search.c} implements the Lisp primitives for searching for text in @@ -3122,7 +3298,7 @@ routines used in @file{grep} and other GNU utilities. @example - 20476 doprnt.c +doprnt.c @end example @file{doprnt.c} implements formatted-string processing, similar to @@ -3131,7 +3307,7 @@ routines used in @file{grep} and other GNU utilities. @example - 15372 undo.c +undo.c @end example This module implements the undo mechanism for tracking buffer changes. @@ -3143,13 +3319,11 @@ Most of this could be implemented in Lisp. @section Editor-Level Control Flow Modules @example - size name -------- --------------------- - 84546 event-Xt.c - 121483 event-stream.c - 6658 event-tty.c - 49271 events.c - 14459 events.h +event-Xt.c +event-stream.c +event-tty.c +events.c +events.h @end example These implement the handling of events (user input and other system @@ -3189,8 +3363,8 @@ events from all different kinds of frames. @example - 129583 keymap.c - 2621 keymap.h +keymap.c +keymap.h @end example @file{keymap.c} and @file{keymap.h} define the @dfn{keymap} Lisp object @@ -3202,7 +3376,7 @@ relevant keymaps.) @example - 25212 keyboard.c +keyboard.c @end example @file{keyboard.c} contains functions that implement the actual editor @@ -3213,8 +3387,8 @@ dispatches events. This code is also rather tricky, just like @example - 9973 macros.c - 1397 macros.h +macros.c +macros.h @end example These two modules contain the basic code for defining keyboard macros. @@ -3224,7 +3398,7 @@ macros is mixed in with the event-handling code in @file{event-stream.c}. @example - 23234 minibuf.c +minibuf.c @end example This contains some miscellaneous code related to the minibuffer (most of @@ -3243,17 +3417,15 @@ code is loaded). @section Modules for the Basic Displayable Lisp Objects @example - size name -------- --------------------- - 985 device-ns.h - 6454 device-stream.c - 1196 device-stream.h - 9526 device-tty.c - 8660 device-tty.h - 43798 device-x.c - 11667 device-x.h - 26056 device.c - 22993 device.h +device-ns.h +device-stream.c +device-stream.h +device-tty.c +device-tty.h +device-x.c +device-x.h +device.c +device.h @end example These modules implement the @dfn{device} Lisp object type. This @@ -3272,12 +3444,12 @@ subtypes (X, TTY, NeXTstep, Microsoft Windows, etc.) as devices do. @example - 934 frame-ns.h - 2303 frame-tty.c - 69205 frame-x.c - 5976 frame-x.h - 68175 frame.c - 15080 frame.h +frame-ns.h +frame-tty.c +frame-x.c +frame-x.h +frame.c +frame.h @end example Each device contains one or more frames in which objects (e.g. text) are @@ -3294,8 +3466,8 @@ provide the generic and device-type-specific operations on frames @example - 160783 window.c - 15974 window.h +window.c +window.h @end example @cindex window (in Emacs) @@ -3319,63 +3491,61 @@ types such as scrollbars. @section Modules for other Display-Related Lisp Objects @example - size name -------- --------------------- - 54397 faces.c - 15173 faces.h +faces.c +faces.h @end example @example - 4961 bitmaps.h - 954 glyphs-ns.h - 105345 glyphs-x.c - 4288 glyphs-x.h - 72102 glyphs.c - 16356 glyphs.h +bitmaps.h +glyphs-ns.h +glyphs-x.c +glyphs-x.h +glyphs.c +glyphs.h @end example @example - 952 objects-ns.h - 9971 objects-tty.c - 1465 objects-tty.h - 32326 objects-x.c - 2806 objects-x.h - 31944 objects.c - 6809 objects.h +objects-ns.h +objects-tty.c +objects-tty.h +objects-x.c +objects-x.h +objects.c +objects.h @end example @example - 57511 menubar-x.c - 11243 menubar.c +menubar-x.c +menubar.c @end example @example - 25012 scrollbar-x.c - 2554 scrollbar-x.h - 26954 scrollbar.c - 2778 scrollbar.h +scrollbar-x.c +scrollbar-x.h +scrollbar.c +scrollbar.h @end example @example - 23117 toolbar-x.c - 43456 toolbar.c - 4280 toolbar.h +toolbar-x.c +toolbar.c +toolbar.h @end example @example - 25070 font-lock.c +font-lock.c @end example This file provides C support for syntax highlighting -- i.e. @@ -3386,10 +3556,10 @@ this is fast. @example - 32180 dgif_lib.c - 3999 gif_err.c - 10697 gif_lib.h - 9371 gifalloc.c +dgif_lib.c +gif_err.c +gif_lib.h +gifalloc.c @end example These modules decode GIF-format image files, for use with glyphs. @@ -3400,13 +3570,11 @@ These modules decode GIF-format image files, for use with glyphs. @section Modules for the Redisplay Mechanism @example - size name -------- --------------------- - 38692 redisplay-output.c - 40835 redisplay-tty.c - 65069 redisplay-x.c - 234142 redisplay.c - 17026 redisplay.h +redisplay-output.c +redisplay-tty.c +redisplay-x.c +redisplay.c +redisplay.h @end example These files provide the redisplay mechanism. As with many other @@ -3437,7 +3605,7 @@ respectively. @example - 14129 indent.c +indent.c @end example This module contains various functions and Lisp primitives for @@ -3449,9 +3617,9 @@ module needs work. @example - 14754 termcap.c - 2141 terminfo.c - 7253 tparam.c +termcap.c +terminfo.c +tparam.c @end example These files contain functions for working with the termcap (BSD-style) @@ -3461,8 +3629,8 @@ escape sequences, used when XEmacs is displaying in a TTY. @example - 10869 cm.c - 5876 cm.h +cm.c +cm.h @end example These files provide some miscellaneous TTY-output functions and should @@ -3474,10 +3642,8 @@ probably be merged into @file{redisplay-tty.c}. @section Modules for Interfacing with the File System @example - size name -------- --------------------- - 43362 lstream.c - 14240 lstream.h +lstream.c +lstream.h @end example These modules implement the @dfn{stream} Lisp object type. This is an @@ -3504,7 +3670,7 @@ types of streams; others are provided, e.g., in @file{mule-coding.c}. @example - 126926 fileio.c +fileio.c @end example This implements the basic primitives for interfacing with the file @@ -3521,7 +3687,7 @@ the higher-level user commands in @file{commands.c} and @example - 10960 filelock.c +filelock.c @end example This file provides functions for detecting clashes between different @@ -3536,7 +3702,7 @@ synched up with the external changes if necessary. @example - 4527 filemode.c +filemode.c @end example This file provides some miscellaneous functions that construct a @@ -3547,8 +3713,8 @@ This file provides some miscellaneous functions that construct a @example - 22855 dired.c - 2094 ndir.h +dired.c +ndir.h @end example These files implement the XEmacs interface to directory searching. This @@ -3564,7 +3730,7 @@ those systems, directories can be read directly as files, and parsed.) @example - 4311 realpath.c +realpath.c @end example This file provides an implementation of the @code{realpath()} function @@ -3577,25 +3743,24 @@ a broken implementation. @section Modules for Other Aspects of the Lisp Interpreter and Object System @example - size name -------- --------------------- - 22290 elhash.c - 2454 elhash.h - 12169 hash.c - 3369 hash.h +elhash.c +elhash.h +hash.c +hash.h @end example -These files implement the @dfn{hashtable} Lisp object type. +These files provide two implementations of hash tables. Files @file{hash.c} and @file{hash.h} provide a generic C implementation of -hash tables (which can stand independently of XEmacs), and -@file{elhash.c} and @file{elhash.h} provide a Lisp interface onto the C -hash tables using the hashtable Lisp object type. - +hash tables which can stand independently of XEmacs. Files +@file{elhash.c} and @file{elhash.h} provide a separate implementation of +hash tables that can store only Lisp objects, and knows about Lispy +things like garbage collection, and implement the @dfn{hash-table} Lisp +object type. @example - 95691 specifier.c - 11167 specifier.h +specifier.c +specifier.h @end example This module implements the @dfn{specifier} Lisp object type. This is @@ -3611,9 +3776,9 @@ can be derived). @example - 43058 chartab.c - 6503 chartab.h - 9918 casetab.c +chartab.c +chartab.h +casetab.c @end example @file{chartab.c} and @file{chartab.h} implement the @dfn{char table} @@ -3633,8 +3798,8 @@ and to do case-insensitive searching. @example - 49593 syntax.c - 10200 syntax.h +syntax.c +syntax.h @end example @cindex scanner @@ -3651,7 +3816,7 @@ comments, etc. @example - 10438 casefiddle.c +casefiddle.c @end example This module implements various Lisp primitives for upcasing, downcasing @@ -3660,7 +3825,7 @@ and capitalizing strings or regions of buffers. @example - 20234 rangetab.c +rangetab.c @end example This module implements the @dfn{range table} Lisp object type, which @@ -3670,8 +3835,8 @@ objects. @example - 3201 opaque.c - 2206 opaque.h +opaque.c +opaque.h @end example This module implements the @dfn{opaque} Lisp object type, an @@ -3693,7 +3858,7 @@ create a new Lisp object type -- it's not hard.) @example - 8783 abbrev.c +abbrev.c @end example This function provides a few primitives for doing dynamic abbreviation @@ -3706,7 +3871,7 @@ is itself in C only for speed.) @example - 21934 doc.c +doc.c @end example This function provides primitives for retrieving the documentation @@ -3725,7 +3890,7 @@ the appropriate documentation string.) @example - 13197 md5.c +md5.c @end example This function provides a Lisp primitive that implements the MD5 secure @@ -3740,11 +3905,9 @@ various security applications on the Internet. @section Modules for Interfacing with the Operating System @example - size name -------- --------------------- - 33533 callproc.c - 89697 process.c - 4663 process.h +callproc.c +process.c +process.h @end example These modules allow XEmacs to spawn and communicate with subprocesses @@ -3789,8 +3952,8 @@ subprocesses. @example - 136029 sysdep.c - 5986 sysdep.h +sysdep.c +sysdep.h @end example These modules implement most of the low-level, messy operating-system @@ -3803,15 +3966,15 @@ provide them or have broken versions. @example - 3605 sysdir.h - 6708 sysfile.h - 2027 sysfloat.h - 2918 sysproc.h - 745 syspwd.h - 7643 syssignal.h - 6892 systime.h - 12477 systty.h - 3487 syswait.h +sysdir.h +sysfile.h +sysfloat.h +sysproc.h +syspwd.h +syssignal.h +systime.h +systty.h +syswait.h @end example These header files provide consistent interfaces onto system-dependent @@ -3866,15 +4029,15 @@ an int). @example - 7940 hpplay.c - 10920 libsst.c - 1480 libsst.h - 3260 libst.h - 15355 linuxplay.c - 15849 nas.c - 19133 sgiplay.c - 15411 sound.c - 7358 sunplay.c +hpplay.c +libsst.c +libsst.h +libst.h +linuxplay.c +nas.c +sgiplay.c +sound.c +sunplay.c @end example These files implement the ability to play various sounds on some types @@ -3911,8 +4074,8 @@ currently in use. @example - 44368 tooltalk.c - 2137 tooltalk.h +tooltalk.c +tooltalk.h @end example These two modules implement an interface to the ToolTalk protocol, which @@ -3928,7 +4091,7 @@ parts of the SPARCWorks development environment. @example - 22695 getloadavg.c +getloadavg.c @end example This module provides the ability to retrieve the system's current load @@ -3938,21 +4101,7 @@ and requires a lot of special-case code.) @example - 148520 energize.c - 6896 energize.h -@end example - -This module provides code to interface to an Energize server (when -XEmacs is used as part of Lucid's Energize development environment) and -provides some other Energize-specific functions. Much of the code in -this module should be made more general-purpose and moved elsewhere, but -is no longer very relevant now that Lucid is defunct. It also hasn't -worked since version 19.12, since nobody has been maintaining it. - - - -@example - 2861 sunpro.c +sunpro.c @end example This module provides a small amount of code used internally at Sun to @@ -3961,10 +4110,10 @@ keep statistics on the usage of XEmacs. @example - 5548 broken-sun.h - 3468 strcmp.c - 2179 strcpy.c - 1650 sunOS-fix.c +broken-sun.h +strcmp.c +strcpy.c +sunOS-fix.c @end example These files provide replacement functions and prototypes to fix numerous @@ -3973,7 +4122,7 @@ bugs in early releases of SunOS 4.1. @example - 11669 hftctl.c +hftctl.c @end example This module provides some terminal-control code necessary on versions of @@ -3982,27 +4131,8 @@ AIX prior to 4.1. @example - 1776 acldef.h - 1602 chpdef.h - 9032 uaf.h - 105 vlimit.h - 7145 vms-pp.c - 1158 vms-pwd.h - 26532 vmsfns.c - 6038 vmsmap.c - 695 vmspaths.h - 17482 vmsproc.c - 469 vmsproc.h -@end example - -All of these files are used for VMS support, which has never worked in -XEmacs. - - - -@example - 28316 msdos.c - 1472 msdos.h +msdos.c +msdos.h @end example These modules are used for MS-DOS support, which does not work in @@ -4014,9 +4144,7 @@ XEmacs. @section Modules for Interfacing with X Windows @example - size name -------- --------------------- - 3196 Emacs.ad.h +Emacs.ad.h @end example A file generated from @file{Emacs.ad}, which contains XEmacs-supplied @@ -4025,9 +4153,9 @@ fallback resources (so that XEmacs has pretty defaults). @example - 24242 EmacsFrame.c - 6979 EmacsFrame.h - 3351 EmacsFrameP.h +EmacsFrame.c +EmacsFrame.h +EmacsFrameP.h @end example These modules implement an Xt widget class that encapsulates a frame. @@ -4042,9 +4170,9 @@ mercilessly at the slightest change. Such is life under Xt. @example - 8178 EmacsManager.c - 1967 EmacsManager.h - 1895 EmacsManagerP.h +EmacsManager.c +EmacsManager.h +EmacsManagerP.h @end example These modules implement a simple Xt manager (i.e. composite) widget @@ -4054,10 +4182,10 @@ thought, it makes sense, considering how amazingly broken Xt is. @example - 13188 EmacsShell-sub.c - 4588 EmacsShell.c - 2180 EmacsShell.h - 3133 EmacsShellP.h +EmacsShell-sub.c +EmacsShell.c +EmacsShell.h +EmacsShellP.h @end example These modules implement two Xt widget classes that are subclasses of @@ -4068,8 +4196,8 @@ developers. @example - 9673 xgccache.c - 1111 xgccache.h +xgccache.c +xgccache.h @end example These modules provide functions for maintenance and caching of GC's @@ -4079,7 +4207,7 @@ needs to be rewritten. @example - 69181 xselect.c +xselect.c @end example @cindex selections @@ -4090,10 +4218,10 @@ with each other. @example - 929 xintrinsic.h - 1038 xintrinsicp.h - 1579 xmmanagerp.h - 1585 xmprimitivep.h +xintrinsic.h +xintrinsicp.h +xmmanagerp.h +xmprimitivep.h @end example These header files are similar in spirit to the @file{sys*.h} files and buffer @@ -4113,8 +4241,8 @@ against different implementations of Xt and Motif. @example - 16930 xmu.c - 936 xmu.h +xmu.c +xmu.h @end example These files provide an emulation of the Xmu library for those systems @@ -4123,17 +4251,17 @@ These files provide an emulation of the Xmu library for those systems @example - 4201 ExternalClient-Xlib.c - 18083 ExternalClient.c - 2035 ExternalClient.h - 2104 ExternalClientP.h - 22684 ExternalShell.c - 1709 ExternalShell.h - 1971 ExternalShellP.h - 2478 extw-Xlib.c - 1481 extw-Xlib.h - 6565 extw-Xt.c - 1430 extw-Xt.h +ExternalClient-Xlib.c +ExternalClient.c +ExternalClient.h +ExternalClientP.h +ExternalShell.c +ExternalShell.h +ExternalShellP.h +extw-Xlib.c +extw-Xlib.h +extw-Xt.c +extw-Xt.h @end example @cindex external widget @@ -4154,31 +4282,20 @@ Don't touch this code; something is liable to break if you do. -@example - 31014 epoch.c -@end example - -This file provides some additional, Epoch-compatible, functionality for -interfacing to the X Window System. - - - @node Modules for Internationalization @section Modules for Internationalization @example - size name -------- --------------------- - 42836 mule-canna.c - 16737 mule-ccl.c - 41080 mule-charset.c - 30176 mule-charset.h - 146844 mule-coding.c - 16588 mule-coding.h - 6996 mule-mcpath.c - 2899 mule-mcpath.h - 57158 mule-wnnfns.c - 3351 mule.c +mule-canna.c +mule-ccl.c +mule-charset.c +mule-charset.h +mule-coding.c +mule-coding.h +mule-mcpath.c +mule-mcpath.h +mule-wnnfns.c +mule.c @end example These files implement the MULE (Asian-language) support. Note that MULE @@ -4190,7 +4307,7 @@ to support). This code is still in beta. XEmacs MULE support. @file{mule-charset.*} implements the @dfn{charset} Lisp object type, which encapsulates a character set (an ordered one- or two-dimensional set of characters, such as US ASCII or JISX0208 Japanese -Kanji). +Kanji). @file{mule-coding.*} implements the @dfn{coding-system} Lisp object type, which encapsulates a method of converting between different @@ -4223,7 +4340,7 @@ be elsewhere. @example - 9400 intl.c +intl.c @end example This provides some miscellaneous internationalization code for @@ -4233,7 +4350,7 @@ method. None of this code is currently working. @example - 1764 iso-wide.h +iso-wide.h @end example This contains leftover code from an earlier implementation of @@ -4260,7 +4377,7 @@ Asian-language support, and is not currently used. * Symbol:: * Marker:: * String:: -* Bytecode:: +* Compiled Function:: @end menu @node Introduction to Allocation @@ -4294,7 +4411,7 @@ Lisp object types into four broad categories: (a) Those for whom the value directly represents the contents of the Lisp object. Only two types are in this category: integers and characters. No special allocation or garbage collection is necessary -for such objects. Lisp objects of these types do not need to be +for such objects. Lisp objects of these types do not need to be @code{GCPRO}ed. @end itemize @@ -4337,13 +4454,13 @@ to store the type, but it's not clear it's worth making the change. @item (c) Those lrecords that are allocated in frob blocks (see above). This includes the objects that are most common and relatively small, and -includes floats, bytecodes, symbols (when not in category (b)), extents, -events, and markers. With the cleanup of frob blocks done in 19.12, -it's not terribly hard to add more objects to this category, but it's a -bit trickier than adding an object type to type (d) (esp. if the object -needs a finalization method), and is not likely to save much space -unless the object is small and there are many of them. (In fact, if -there are very few of them, it might actually waste space.) +includes floats, compiled functions, symbols (when not in category (b)), +extents, events, and markers. With the cleanup of frob blocks done in +19.12, it's not terribly hard to add more objects to this category, but +it's a bit trickier than adding an object type to type (d) (esp. if the +object needs a finalization method), and is not likely to save much +space unless the object is small and there are many of them. (In fact, +if there are very few of them, it might actually waste space.) @item (d) Those lrecords that are individually @code{malloc()}ed. These are called @dfn{lcrecords}. All other types are in this category. Adding a @@ -5071,8 +5188,8 @@ string data (which would normally be obtained from the now-non-existent The string compactor recognizes this special 0xFFFFFFFF marker and handles it correctly. -@node Bytecode -@section Bytecode +@node Compiled Function +@section Compiled Function Not yet documented. @@ -5205,12 +5322,12 @@ so we'll look at this first): @noindent @example - asynch. asynch. asynch. asynch. [Collectors in -kbd events kbd events process process the OS] - | | output output - | | | | - | | | | SIGINT, [signal handlers - | | | | SIGQUIT, in XEmacs] + asynch. asynch. asynch. asynch. [Collectors in +kbd events kbd events process process the OS] + | | output output + | | | | + | | | | SIGINT, [signal handlers + | | | | SIGQUIT, in XEmacs] V V V V SIGWINCH, file file file file SIGALRM desc. desc. desc. desc. | @@ -5224,27 +5341,27 @@ kbd events kbd events process process the OS] | | | | | | V V V V V V ------>-----------<----------------<---------------- - | - | - | [collected using select() in emacs_tty_next_event() - | and converted to the appropriate Emacs event] - | - | - V (above this line is TTY-specific) - Emacs ------------------------------------------------ - event (below this line is the generic event mechanism) - | - | -was there if not, call -a SIGINT? emacs_tty_next_event() - | | - | | - | | - V V - --->-------<---- + | + | + | [collected using select() in emacs_tty_next_event() + | and converted to the appropriate Emacs event] + | + | + V (above this line is TTY-specific) + Emacs ----------------------------------------------- + event (below this line is the generic event mechanism) + | + | +was there if not, call +a SIGINT? emacs_tty_next_event() + | | + | | + | | + V V + --->------<---- | - | [collected in event_stream_next_event(); - | SIGINT is converted using maybe_read_quit_event()] + | [collected in event_stream_next_event(); + | SIGINT is converted using maybe_read_quit_event()] V Emacs event @@ -5254,9 +5371,9 @@ a SIGINT? emacs_tty_next_event() | | command event queue | - if not from command - (contains events that were event queue, call - read earlier but not processed, event_stream_next_event() + if not from command + (contains events that were event queue, call + read earlier but not processed, event_stream_next_event() typically when waiting in a | sit-for, sleep-for, etc. for | a particular event to be received) | @@ -5265,8 +5382,8 @@ a SIGINT? emacs_tty_next_event() V V ---->------------------------------------<---- | - | [collected in - | next_event_internal()] + | [collected in + | next_event_internal()] | unread- unread- event from | command- command- keyboard else, call @@ -5308,45 +5425,45 @@ it's the same as the above diagram): @example asynch. asynch. asynch. asynch. [Collectors in kbd kbd process process the OS] -events events output output - | | | | - | | | | asynch. asynch. [Collectors in the - | | | | X X OS and X Window System] - | | | | events events +events events output output + | | | | + | | | | asynch. asynch. [Collectors in the + | | | | X X OS and X Window System] + | | | | events events | | | | | | | | | | | | - | | | | | | SIGINT, [signal handlers - | | | | | | SIGQUIT, in XEmacs] - | | | | | | SIGWINCH, - | | | | | | SIGALRM - | | | | | | | - | | | | | | | - | | | | | | | timeouts + | | | | | | SIGINT, [signal handlers + | | | | | | SIGQUIT, in XEmacs] + | | | | | | SIGWINCH, + | | | | | | SIGALRM + | | | | | | | + | | | | | | | + | | | | | | | timeouts | | | | | | | | | | | | | | | | | | | | | | V | - V V V V V V fake | - file file file file file file file | - desc. desc. desc. desc. desc. desc. desc. | - (TTY) (TTY) (pipe) (pipe) (socket) (socket) (pipe) | + V V V V V V fake | + file file file file file file file | + desc. desc. desc. desc. desc. desc. desc. | + (TTY) (TTY) (pipe) (pipe) (socket) (socket) (pipe) | | | | | | | | | | | | | | | | | | | | | | | | | - V V V V V V V V + V V V V V V V V --->----------------------------------------<---------<------ | | | - | | | [collected using select() in - | | | _XtWaitForSomething(), called - | | | from XtAppProcessEvent(), called - | | | in emacs_Xt_next_event(); - | | | dispatched to various callbacks] + | | |[collected using select() in + | | | _XtWaitForSomething(), called + | | | from XtAppProcessEvent(), called + | | | in emacs_Xt_next_event(); + | | | dispatched to various callbacks] | | | | | | - emacs_Xt_ p_s_callback(), | [popup_selection_callback] - event_handler() x_u_v_s_callback(),| [x_update_vertical_scrollbar_ - | x_u_h_s_callback(),| callback] - | search_callback() | [x_update_horizontal_scrollbar_ - | | | callback] + emacs_Xt_ p_s_callback(), | [popup_selection_callback] + event_handler() x_u_v_s_callback(),| [x_update_vertical_scrollbar_ + | x_u_h_s_callback(),| callback] + | search_callback() | [x_update_horizontal_scrollbar_ + | | | callback] | | | | | | enqueue_Xt_ signal_special_ | @@ -5362,7 +5479,7 @@ events events output output -->----------<-- | | | | | - dispatch Xt_what_callback() + dispatch Xt_what_callback() event sets flags queue | | | @@ -5370,15 +5487,15 @@ events events output output | | | | ---->-----------<-------- - | + | | | [collected and converted as appropriate in | emacs_Xt_next_event()] - | - | - V (above this line is Xt-specific) - Emacs ------------------------------------------------ - event (below this line is the generic event mechanism) + | + | + V (above this line is Xt-specific) + Emacs ------------------------------------------------ + event (below this line is the generic event mechanism) | | was there if not, call @@ -5400,9 +5517,9 @@ a SIGINT? emacs_Xt_next_event() | | command event queue | - if not from command - (contains events that were event queue, call - read earlier but not processed, event_stream_next_event() + if not from command + (contains events that were event queue, call + read earlier but not processed, event_stream_next_event() typically when waiting in a | sit-for, sleep-for, etc. for | a particular event to be received) | @@ -5411,8 +5528,8 @@ a SIGINT? emacs_Xt_next_event() V V ---->----------------------------------<------ | - | [collected in - | next_event_internal()] + | [collected in + | next_event_internal()] | unread- unread- event from | command- command- keyboard else, call @@ -5495,79 +5612,129 @@ Not yet documented. @code{Feval()} evaluates the form (a Lisp object) that is passed to it. Note that evaluation is only non-trivial for two types of objects: symbols and conses. A symbol is evaluated simply by calling -symbol-value on it and returning the value. +@code{symbol-value} on it and returning the value. Evaluating a cons means calling a function. First, @code{eval} checks to see if garbage-collection is necessary, and calls -@code{Fgarbage_collect()} if so. It then increases the evaluation depth -by 1 (@code{lisp_eval_depth}, which is always less than @code{max_lisp_eval_depth}) and adds an -element to the linked list of @code{struct backtrace}'s -(@code{backtrace_list}). Each such structure contains a pointer to the -function being called plus a list of the function's arguments. -Originally these values are stored unevalled, and as they are evaluated, -the backtrace structure is updated. Garbage collection pays attention -to the objects pointed to in the backtrace structures (garbage -collection might happen while a function is being called or while an -argument is being evaluated, and there could easily be no other -references to the arguments in the argument list; once an argument is -evaluated, however, the unevalled version is not needed by eval, and so -the backtrace structure is changed). - - At this point, the function to be called is determined by looking at +@code{garbage_collect_1()} if so. It then increases the evaluation +depth by 1 (@code{lisp_eval_depth}, which is always less than +@code{max_lisp_eval_depth}) and adds an element to the linked list of +@code{struct backtrace}'s (@code{backtrace_list}). Each such structure +contains a pointer to the function being called plus a list of the +function's arguments. Originally these values are stored unevalled, and +as they are evaluated, the backtrace structure is updated. Garbage +collection pays attention to the objects pointed to in the backtrace +structures (garbage collection might happen while a function is being +called or while an argument is being evaluated, and there could easily +be no other references to the arguments in the argument list; once an +argument is evaluated, however, the unevalled version is not needed by +eval, and so the backtrace structure is changed). + +At this point, the function to be called is determined by looking at the car of the cons (if this is a symbol, its function definition is retrieved and the process repeated). The function should then consist -of either a @code{Lisp_Subr} (built-in function), a -@code{Lisp_Compiled_Function} object, or a cons whose car is the symbol -@code{autoload}, @code{macro} or @code{lambda}. +of either a @code{Lisp_Subr} (built-in function written in C), a +@code{Lisp_Compiled_Function} object, or a cons whose car is one of the +symbols @code{autoload}, @code{macro} or @code{lambda}. If the function is a @code{Lisp_Subr}, the lisp object points to a @code{struct Lisp_Subr} (created by @code{DEFUN()}), which contains a pointer to the C function, a minimum and maximum number of arguments -(possibly the special constants @code{MANY} or @code{UNEVALLED}), a +(or possibly the special constants @code{MANY} or @code{UNEVALLED}), a pointer to the symbol referring to that subr, and a couple of other things. If the subr wants its arguments @code{UNEVALLED}, they are passed raw as a list. Otherwise, an array of evaluated arguments is created and put into the backtrace structure, and either passed whole (@code{MANY}) or each argument is passed as a C argument. - If the function is a @code{Lisp_Compiled_Function} object or a lambda, -@code{apply_lambda()} is called. If the function is a macro, -[..... fill in] is done. If the function is an autoload, +If the function is a @code{Lisp_Compiled_Function}, +@code{funcall_compiled_function()} is called. If the function is a +lambda list, @code{funcall_lambda()} is called. If the function is a +macro, [..... fill in] is done. If the function is an autoload, @code{do_autoload()} is called to load the definition and then eval starts over [explain this more]. - When @code{Feval} exits, the evaluation depth is reduced by one, the +When @code{Feval()} exits, the evaluation depth is reduced by one, the debugger is called if appropriate, and the current backtrace structure is removed from the list. - @code{apply_lambda()} is passed a function, a list of arguments, and a -flag indicating whether to evaluate the arguments. It creates an array -of (possibly) evaluated arguments and fixes up the backtrace structure, -just like eval does. Then it calls @code{funcall_lambda()}. +Both @code{funcall_compiled_function()} and @code{funcall_lambda()} need +to go through the list of formal parameters to the function and bind +them to the actual arguments, checking for @code{&rest} and +@code{&optional} symbols in the formal parameters and making sure the +number of actual arguments is correct. +@code{funcall_compiled_function()} can do this a little more +efficiently, since the formal parameter list can be checked for sanity +when the compiled function object is created. + +@code{funcall_lambda()} simply calls @code{Fprogn} to execute the code +in the lambda list. + +@code{funcall_compiled_function()} calls the real byte-code interpreter +@code{execute_optimized_program()} on the byte-code instructions, which +are converted into an internal form for faster execution. + +When a compiled function is executed for the first time by +@code{funcall_compiled_function()}, or when it is @code{Fpurecopy()}ed +during the dump phase of building XEmacs, the byte-code instructions are +converted from a @code{Lisp_String} (which is inefficient to access, +especially in the presence of MULE) into a @code{Lisp_Opaque} object +containing an array of unsigned char, which can be directly executed by +the byte-code interpreter. At this time the byte code is also analyzed +for validity and transformed into a more optimized form, so that +@code{execute_optimized_program()} can really fly. + +Here are some of the optimizations performed by the internal byte-code +transformer: +@enumerate +@item +References to the @code{constants} array are checked for out-of-range +indices, so that the byte interpreter doesn't have to. +@item +References to the @code{constants} array that will be used as a Lisp +variable are checked for being correct non-constant (i.e. not @code{t}, +@code{nil}, or @code{keywordp}) symbols, so that the byte interpreter +doesn't have to. +@item +The maxiumum number of variable bindings in the byte-code is +pre-computed, so that space on the @code{specpdl} stack can be +pre-reserved once for the whole function execution. +@item +All byte-code jumps are relative to the current program counter instead +of the start of the program, thereby saving a register. +@item +One-byte relative jumps are converted from the byte-code form of unsigned +chars offset by 127 to machine-friendly signed chars. +@end enumerate - @code{funcall_lambda()} goes through the formal arguments to the -function and binds them to the actual arguments, checking for -@code{&rest} and @code{&optional} symbols in the formal arguments and -making sure the number of actual arguments is correct. Then either -@code{progn} or @code{byte-code} is called to actually execute the body -and return a value. +Of course, this transformation of the @code{instructions} should not be +visible to the user, so @code{Fcompiled_function_instructions()} needs +to know how to convert the optimized opaque object back into a Lisp +string that is identical to the original string from the @file{.elc} +file. (Actually, the resulting string may (rarely) contain slightly +different, yet equivalent, byte code.) - @code{Ffuncall()} implements Lisp @code{funcall}. @code{(funcall fun +@code{Ffuncall()} implements Lisp @code{funcall}. @code{(funcall fun x1 x2 x3 ...)} is equivalent to @code{(eval (list fun (quote x1) (quote x2) (quote x3) ...))}. @code{Ffuncall()} contains its own code to do -the evaluation, however, and is almost identical to eval. +the evaluation, however, and is very similar to @code{Feval()}. + +From the performance point of view, it is worth knowing that most of the +time in Lisp evaluation is spent executing @code{Lisp_Subr} and +@code{Lisp_Compiled_Function} objects via @code{Ffuncall()} (not +@code{Feval()}). - @code{Fapply()} implements Lisp @code{apply}, which is very similar to +@code{Fapply()} implements Lisp @code{apply}, which is very similar to @code{funcall} except that if the last argument is a list, the result is the same as if each of the arguments in the list had been passed separately. @code{Fapply()} does some business to expand the last argument if it's a list, then calls @code{Ffuncall()} to do the work. - @code{apply1()}, @code{call0()}, @code{call1()}, @code{call2()}, and +@code{apply1()}, @code{call0()}, @code{call1()}, @code{call2()}, and @code{call3()} call a function, passing it the argument(s) given (the arguments are given as separate C arguments rather than being passed as -an array). @code{apply1()} uses @code{apply} while the others use -@code{funcall}. +an array). @code{apply1()} uses @code{Fapply()} while the others use +@code{Ffuncall()} to do the real work. @node Dynamic Binding; The specbinding Stack; Unwind-Protects @section Dynamic Binding; The specbinding Stack; Unwind-Protects @@ -5575,7 +5742,8 @@ an array). @code{apply1()} uses @code{apply} while the others use @example struct specbinding @{ - Lisp_Object symbol, old_value; + Lisp_Object symbol; + Lisp_Object old_value; Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */ @}; @end example @@ -5629,13 +5797,15 @@ the symbol's value). @code{prog1}, @code{prog2}, @code{setq}, @code{quote}, @code{function}, @code{let*}, @code{let}, @code{while} - All of these are very simple and work as expected, calling +All of these are very simple and work as expected, calling @code{Feval()} or @code{Fprogn()} as necessary and (in the case of @code{let} and @code{let*}) using @code{specbind()} to create bindings -and @code{unbind_to()} to undo the bindings when finished. Note that -these functions do a lot of @code{GCPRO}ing to protect their arguments -from garbage collection because they call @code{Feval()} (@pxref{Garbage -Collection}). +and @code{unbind_to()} to undo the bindings when finished. + +Note that, with the exeption of @code{Fprogn}, these functions are +typically called in real life only in interpreted code, since the byte +compiler knows how to convert calls to these functions directly into +byte code. @node Catch and Throw @section Catch and Throw @@ -5887,7 +6057,7 @@ enclosed in a @code{save-excursion} so that the former current buffer gets restored when the code is finished). However, calling @code{set-buffer} will NOT cause a permanent change in the current buffer. The reason for this is that the top-level event loop sets -@code{current_buffer} to the buffer of the selected window, each time +@code{current_buffer} to the buffer of the selected window, each time it finishes executing a user command. @end enumerate @@ -6348,7 +6518,7 @@ encodings: @node Japanese EUC (Extended Unix Code) @subsection Japanese EUC (Extended Unix Code) -This encompasses the character sets Printing-ASCII, Japanese-JISSX0201, +This encompasses the character sets Printing-ASCII, Japanese-JISX0201, and Japanese-JISX0208-Kana (half-width katakana, the right half of JISX0201). It uses 8-bit bytes. @@ -6538,45 +6708,45 @@ described above. @example CCL PROGRAM SYNTAX: - CCL_PROGRAM := (CCL_MAIN_BLOCK - [ CCL_EOF_BLOCK ]) - - CCL_MAIN_BLOCK := CCL_BLOCK - CCL_EOF_BLOCK := CCL_BLOCK - - CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...]) - STATEMENT := - SET | IF | BRANCH | LOOP | REPEAT | BREAK - | READ | WRITE - - SET := (REG = EXPRESSION) | (REG SELF_OP EXPRESSION) - | INT-OR-CHAR - - EXPRESSION := ARG | (EXPRESSION OP ARG) - - IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK) - BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...]) - LOOP := (loop STATEMENT [STATEMENT ...]) - BREAK := (break) - REPEAT := (repeat) - | (write-repeat [REG | INT-OR-CHAR | string]) - | (write-read-repeat REG [INT-OR-CHAR | string | ARRAY]?) - READ := (read REG) | (read REG REG) - | (read-if REG ARITH_OP ARG CCL_BLOCK CCL_BLOCK) - | (read-branch REG CCL_BLOCK [CCL_BLOCK ...]) - WRITE := (write REG) | (write REG REG) - | (write INT-OR-CHAR) | (write STRING) | STRING - | (write REG ARRAY) - END := (end) - - REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 - ARG := REG | INT-OR-CHAR - OP := + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // - | < | > | == | <= | >= | != - SELF_OP := - += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= - ARRAY := '[' INT-OR-CHAR ... ']' - INT-OR-CHAR := INT | CHAR + CCL_PROGRAM := (CCL_MAIN_BLOCK + [ CCL_EOF_BLOCK ]) + + CCL_MAIN_BLOCK := CCL_BLOCK + CCL_EOF_BLOCK := CCL_BLOCK + + CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...]) + STATEMENT := + SET | IF | BRANCH | LOOP | REPEAT | BREAK + | READ | WRITE + + SET := (REG = EXPRESSION) | (REG SELF_OP EXPRESSION) + | INT-OR-CHAR + + EXPRESSION := ARG | (EXPRESSION OP ARG) + + IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK) + BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...]) + LOOP := (loop STATEMENT [STATEMENT ...]) + BREAK := (break) + REPEAT := (repeat) + | (write-repeat [REG | INT-OR-CHAR | string]) + | (write-read-repeat REG [INT-OR-CHAR | string | ARRAY]?) + READ := (read REG) | (read REG REG) + | (read-if REG ARITH_OP ARG CCL_BLOCK CCL_BLOCK) + | (read-branch REG CCL_BLOCK [CCL_BLOCK ...]) + WRITE := (write REG) | (write REG REG) + | (write INT-OR-CHAR) | (write STRING) | STRING + | (write REG ARRAY) + END := (end) + + REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 + ARG := REG | INT-OR-CHAR + OP := + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // + | < | > | == | <= | >= | != + SELF_OP := + += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= + ARRAY := '[' INT-OR-CHAR ... ']' + INT-OR-CHAR := INT | CHAR MACHINE CODE: @@ -6596,13 +6766,13 @@ OPERATOR BIT FIELD (27-bit): XXXXXXXXXXXXXXX RRR TTTTT CCCCCCCCCCCCCCC: constant or address 000000000000rrr: register number -AAAA: 00000 + - 00001 - - 00010 * - 00011 / - 00100 % - 00101 & - 00110 | +AAAA: 00000 + + 00001 - + 00010 * + 00011 / + 00100 % + 00101 & + 00110 | 00111 ~ 01000 << @@ -6614,8 +6784,8 @@ AAAA: 00000 + 01110 not used 01111 not used - 10000 < - 10001 > + 10000 < + 10001 > 10010 == 10011 <= 10100 >= @@ -6623,78 +6793,78 @@ AAAA: 00000 + OPERATORS: TTTTT RRR XX.. -SetCS: 00000 RRR C...C RRR = C...C -SetCL: 00001 RRR ..... RRR = c...c +SetCS: 00000 RRR C...C RRR = C...C +SetCL: 00001 RRR ..... RRR = c...c c.............c -SetR: 00010 RRR ..rrr RRR = rrr -SetA: 00011 RRR ..rrr RRR = array[rrr] - C.............C size of array = C...C - c.............c contents = c...c - -Jump: 00100 000 c...c jump to c...c -JumpCond: 00101 RRR c...c if (!RRR) jump to c...c -WriteJump: 00110 RRR c...c Write1 RRR, jump to c...c -WriteReadJump: 00111 RRR c...c Write1, Read1 RRR, jump to c...c -WriteCJump: 01000 000 c...c Write1 C...C, jump to c...c +SetR: 00010 RRR ..rrr RRR = rrr +SetA: 00011 RRR ..rrr RRR = array[rrr] + C.............C size of array = C...C + c.............c contents = c...c + +Jump: 00100 000 c...c jump to c...c +JumpCond: 00101 RRR c...c if (!RRR) jump to c...c +WriteJump: 00110 RRR c...c Write1 RRR, jump to c...c +WriteReadJump: 00111 RRR c...c Write1, Read1 RRR, jump to c...c +WriteCJump: 01000 000 c...c Write1 C...C, jump to c...c C...C -WriteCReadJump: 01001 RRR c...c Write1 C...C, Read1 RRR, - C.............C and jump to c...c -WriteSJump: 01010 000 c...c WriteS, jump to c...c +WriteCReadJump: 01001 RRR c...c Write1 C...C, Read1 RRR, + C.............C and jump to c...c +WriteSJump: 01010 000 c...c WriteS, jump to c...c C.............C S.............S ... -WriteSReadJump: 01011 RRR c...c WriteS, Read1 RRR, jump to c...c +WriteSReadJump: 01011 RRR c...c WriteS, Read1 RRR, jump to c...c C.............C S.............S ... -WriteAReadJump: 01100 RRR c...c WriteA, Read1 RRR, jump to c...c - C.............C size of array = C...C - c.............c contents = c...c +WriteAReadJump: 01100 RRR c...c WriteA, Read1 RRR, jump to c...c + C.............C size of array = C...C + c.............c contents = c...c ... -Branch: 01101 RRR C...C if (RRR >= 0 && RRR < C..) - c.............c branch to (RRR+1)th address -Read1: 01110 RRR ... read 1-byte to RRR -Read2: 01111 RRR ..rrr read 2-byte to RRR and rrr -ReadBranch: 10000 RRR C...C Read1 and Branch +Branch: 01101 RRR C...C if (RRR >= 0 && RRR < C..) + c.............c branch to (RRR+1)th address +Read1: 01110 RRR ... read 1-byte to RRR +Read2: 01111 RRR ..rrr read 2-byte to RRR and rrr +ReadBranch: 10000 RRR C...C Read1 and Branch c.............c ... -Write1: 10001 RRR ..... write 1-byte RRR -Write2: 10010 RRR ..rrr write 2-byte RRR and rrr -WriteC: 10011 000 ..... write 1-char C...CC +Write1: 10001 RRR ..... write 1-byte RRR +Write2: 10010 RRR ..rrr write 2-byte RRR and rrr +WriteC: 10011 000 ..... write 1-char C...CC C.............C -WriteS: 10100 000 ..... write C..-byte of string +WriteS: 10100 000 ..... write C..-byte of string C.............C S.............S ... -WriteA: 10101 RRR ..... write array[RRR] - C.............C size of array = C...C - c.............c contents = c...c +WriteA: 10101 RRR ..... write array[RRR] + C.............C size of array = C...C + c.............c contents = c...c ... -End: 10110 000 ..... terminate the execution +End: 10110 000 ..... terminate the execution -SetSelfCS: 10111 RRR C...C RRR AAAAA= C...C +SetSelfCS: 10111 RRR C...C RRR AAAAA= C...C ..........AAAAA -SetSelfCL: 11000 RRR ..... RRR AAAAA= c...c +SetSelfCL: 11000 RRR ..... RRR AAAAA= c...c c.............c ..........AAAAA -SetSelfR: 11001 RRR ..Rrr RRR AAAAA= rrr +SetSelfR: 11001 RRR ..Rrr RRR AAAAA= rrr ..........AAAAA -SetExprCL: 11010 RRR ..Rrr RRR = rrr AAAAA c...c +SetExprCL: 11010 RRR ..Rrr RRR = rrr AAAAA c...c c.............c ..........AAAAA -SetExprR: 11011 RRR ..rrr RRR = rrr AAAAA Rrr +SetExprR: 11011 RRR ..rrr RRR = rrr AAAAA Rrr ............Rrr ..........AAAAA -JumpCondC: 11100 RRR c...c if !(RRR AAAAA C..) jump to c...c +JumpCondC: 11100 RRR c...c if !(RRR AAAAA C..) jump to c...c C.............C ..........AAAAA -JumpCondR: 11101 RRR c...c if !(RRR AAAAA rrr) jump to c...c +JumpCondR: 11101 RRR c...c if !(RRR AAAAA rrr) jump to c...c ............rrr ..........AAAAA -ReadJumpCondC: 11110 RRR c...c Read1 and JumpCondC +ReadJumpCondC: 11110 RRR c...c Read1 and JumpCondC C.............C ..........AAAAA -ReadJumpCondR: 11111 RRR c...c Read1 and JumpCondR +ReadJumpCondR: 11111 RRR c...c Read1 and JumpCondR ............rrr ..........AAAAA @end example @@ -6969,7 +7139,7 @@ TTY. Thus, there is a hierarchy console -> display -> frame -> window. There is a separate Lisp object type for each of these four concepts. -Furthermore, there is logically a @dfn{selected console}, +Furthermore, there is logically a @dfn{selected console}, @dfn{selected display}, @dfn{selected frame}, and @dfn{selected window}. Each of these objects is distinguished in various ways, such as being the default object for various functions that act on objects of that type. @@ -7365,9 +7535,10 @@ for extents and both orders are kept current at all times. The normal or @dfn{display} order is as follows: @example -Extent A is ``less than'' extent B, that is, earlier in the display order, -if: A-start < B-start, -or if: A-start = B-start, and A-end > B-end +Extent A is ``less than'' extent B, +that is, earlier in the display order, + if: A-start < B-start, + or if: A-start = B-start, and A-end > B-end @end example So if two extents begin at the same position, the larger of them is the @@ -7376,9 +7547,10 @@ earlier one in the display order (@code{EXTENT_LESS} is true). For the e-order, the same thing holds: @example -Extent A is ``less than'' extent B in e-order, that is, later in the buffer, -if: A-end < B-end, -or if: A-end = B-end, and A-start > B-start +Extent A is ``less than'' extent B in e-order, +that is, later in the buffer, + if: A-end < B-end, + or if: A-end = B-end, and A-start > B-start @end example So if two extents end at the same position, the smaller of them is the diff --git a/man/lispref/building.texi b/man/lispref/building.texi index f7d0dc6..9f962af 100644 --- a/man/lispref/building.texi +++ b/man/lispref/building.texi @@ -358,8 +358,8 @@ command-builder-storage 120 devices-used 2 device-storage 344 frames-used 3 frame-storage 624 image-instances-used 47 image-instance-storage 3008 windows-used 27 windows-freed 2 window-storage 9180 lcrecord-lists-used 15 -lcrecord-list-storage 360 hashtables-used 631 -hashtable-storage 25240 streams-used 1 streams-on-free-list 3 +lcrecord-list-storage 360 hash-tables-used 631 +hash-table-storage 25240 streams-used 1 streams-on-free-list 3 streams-freed 12 stream-storage 91)) @end group @end example diff --git a/man/lispref/compile.texi b/man/lispref/compile.texi index 47b3dd7..8d92bd0 100644 --- a/man/lispref/compile.texi +++ b/man/lispref/compile.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the XEmacs Lisp Reference Manual. -@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. @c See the file lispref.texi for copying conditions. @setfilename ../../info/compile.info @node Byte Compilation, Debugging, Loading, Top @@ -24,6 +24,13 @@ In general, any version of Emacs can run byte-compiled code produced by recent earlier versions of Emacs, but the reverse is not true. In particular, if you compile a program with XEmacs 20, the compiled code may not run in earlier versions. + +The first time a compiled-function object is executed, the byte-code +instructions are validated and the byte-code is further optimized. An +@code{invalid-byte-code} error is signaled if the byte-code is invalid, +for example if it contains invalid opcodes. This usually means a bug in +the byte compiler. + @iftex @xref{Docs and Compilation}. @end iftex @@ -53,7 +60,7 @@ Here is an example: (defun silly-loop (n) "Return time before and after N iterations of a loop." (let ((t1 (current-time-string))) - (while (> (setq n (1- n)) + (while (> (setq n (1- n)) 0)) (list t1 (current-time-string)))) @result{} silly-loop @@ -61,14 +68,13 @@ Here is an example: @group (silly-loop 5000000) -@result{} ("Fri Nov 28 20:56:16 1997" - "Fri Nov 28 20:56:39 1997") ; @r{23 seconds} +@result{} ("Mon Sep 14 15:51:49 1998" + "Mon Sep 14 15:52:07 1998") ; @r{18 seconds} @end group @group (byte-compile 'silly-loop) @result{} #}. However, if the variable @code{print-readably} is -non-@code{nil}, the object is printed beginning with @samp{#[} and -ending with @samp{]}. This representation can be read directly -by the Lisp reader, and is used in byte-compiled files (those ending -in @samp{.elc}). +@dfn{compiled-function objects}. The evaluator handles this data type +specially when it appears as a function to be called. + + The printed representation for a compiled-function object normally +begins with @samp{#}. However, +if the variable @code{print-readably} is non-@code{nil}, the object is +printed beginning with @samp{#[} and ending with @samp{]}. This +representation can be read directly by the Lisp reader, and is used in +byte-compiled files (those ending in @samp{.elc}). In Emacs version 18, there was no compiled-function object data type; compiled functions used the function @code{byte-code} to run the byte code. - A compiled-function object has a number of different elements. + A compiled-function object has a number of different attributes. They are: @table @var @@ -445,7 +451,7 @@ The string containing the byte-code instructions. The vector of Lisp objects referenced by the byte code. These include symbols used as function names and variable names. -@item stacksize +@item stack-size The maximum stack size this function needs. @item doc-string @@ -470,8 +476,8 @@ representation. It is the definition of the command @code{backward-sexp}. @example -# @end example @@ -479,9 +485,9 @@ representation. It is the definition of the command The primitive way to create a compiled-function object is with @code{make-byte-code}: -@defun make-byte-code &rest elements +@defun make-byte-code arglist instructions constants stack-size &optional doc-string interactive This function constructs and returns a compiled-function object -with @var{elements} as its elements. +with the specified attributes. @emph{Please note:} Unlike all other Emacs-lisp functions, calling this with five arguments is @emph{not} the same as calling it with six arguments, @@ -571,9 +577,6 @@ it outputs to a buffer named @samp{*Disassemble*}. Here are two examples of using the @code{disassemble} function. We have added explanatory comments to help you relate the byte-code to the Lisp source; these do not appear in the output of @code{disassemble}. -These examples show unoptimized byte-code. Nowadays byte-code is -usually optimized, but we did not want to rewrite these examples, since -they still serve their purpose. @example @group @@ -597,12 +600,12 @@ they still serve their purpose. @end group @group -0 constant 1 ; @r{Push 1 onto stack.} - -1 varref integer ; @r{Get value of @code{integer}} +0 varref integer ; @r{Get value of @code{integer}} ; @r{from the environment} ; @r{and push the value} ; @r{onto the stack.} + +1 constant 1 ; @r{Push 1 onto stack.} @end group @group @@ -612,39 +615,35 @@ they still serve their purpose. @end group @group -3 goto-if-nil 10 ; @r{Pop and test top of stack;} - ; @r{if @code{nil}, go to 10,} +3 goto-if-nil 1 ; @r{Pop and test top of stack;} + ; @r{if @code{nil},} + ; @r{go to label 1 (which is also byte 7),} ; @r{else continue.} @end group @group -6 constant 1 ; @r{Push 1 onto top of stack.} +5 constant 1 ; @r{Push 1 onto top of stack.} -7 goto 17 ; @r{Go to 17 (in this case, 1 will be} - ; @r{returned by the function).} +6 return ; @r{Return the top element} + ; @r{of the stack.} @end group -@group -10 constant * ; @r{Push symbol @code{*} onto stack.} - -11 varref integer ; @r{Push value of @code{integer} onto stack.} -@end group +7:1 varref integer ; @r{Push value of @code{integer} onto stack.} @group -12 constant factorial ; @r{Push @code{factorial} onto stack.} +8 constant factorial ; @r{Push @code{factorial} onto stack.} -13 varref integer ; @r{Push value of @code{integer} onto stack.} +9 varref integer ; @r{Push value of @code{integer} onto stack.} -14 sub1 ; @r{Pop @code{integer}, decrement value,} +10 sub1 ; @r{Pop @code{integer}, decrement value,} ; @r{push new value onto stack.} @end group @group ; @r{Stack now contains:} ; @minus{} @r{decremented value of @code{integer}} - ; @minus{} @r{@code{factorial}} + ; @minus{} @r{@code{factorial}} ; @minus{} @r{value of @code{integer}} - ; @minus{} @r{@code{*}} @end group @group @@ -659,20 +658,16 @@ they still serve their purpose. ; @minus{} @r{result of recursive} ; @r{call to @code{factorial}} ; @minus{} @r{value of @code{integer}} - ; @minus{} @r{@code{*}} @end group @group -16 call 2 ; @r{Using the first two} - ; @r{(i.e., the top two)} - ; @r{elements of the stack} - ; @r{as arguments,} - ; @r{call the function @code{*},} +12 mult ; @r{Pop top two values off the stack,} + ; @r{multiply them,} ; @r{pushing the result onto the stack.} @end group @group -17 return ; @r{Return the top element} +13 return ; @r{Return the top element} ; @r{of the stack.} @result{} nil @end group @@ -685,7 +680,7 @@ The @code{silly-loop} function is somewhat more complex: (defun silly-loop (n) "Return time before and after N iterations of a loop." (let ((t1 (current-time-string))) - (while (> (setq n (1- n)) + (while (> (setq n (1- n)) 0)) (list t1 (current-time-string)))) @result{} silly-loop @@ -714,7 +709,7 @@ The @code{silly-loop} function is somewhat more complex: @end group @group -3 varref n ; @r{Get value of @code{n} from} +3:1 varref n ; @r{Get value of @code{n} from} ; @r{the environment and push} ; @r{the value onto the stack.} @end group @@ -728,11 +723,9 @@ The @code{silly-loop} function is somewhat more complex: ; @r{i.e., copy the top of} ; @r{the stack and push the} ; @r{copy onto the stack.} -@end group -@group 6 varset n ; @r{Pop the top of the stack,} - ; @r{and bind @code{n} to the value.} + ; @r{and set @code{n} to the value.} ; @r{In effect, the sequence @code{dup varset}} ; @r{copies the top of the stack} @@ -742,69 +735,43 @@ The @code{silly-loop} function is somewhat more complex: @group 7 constant 0 ; @r{Push 0 onto stack.} -@end group -@group 8 gtr ; @r{Pop top two values off stack,} ; @r{test if @var{n} is greater than 0} ; @r{and push result onto stack.} @end group @group -9 goto-if-nil-else-pop 17 ; @r{Goto 17 if @code{n} <= 0} +9 goto-if-not-nil 1 ; @r{Goto label 1 (byte 3) if @code{n} <= 0} ; @r{(this exits the while loop).} ; @r{else pop top of stack} ; @r{and continue} @end group @group -12 constant nil ; @r{Push @code{nil} onto stack} - ; @r{(this is the body of the loop).} +11 varref t1 ; @r{Push value of @code{t1} onto stack.} @end group @group -13 discard ; @r{Discard result of the body} - ; @r{of the loop (a while loop} - ; @r{is always evaluated for} - ; @r{its side effects).} -@end group - -@group -14 goto 3 ; @r{Jump back to beginning} - ; @r{of while loop.} -@end group - -@group -17 discard ; @r{Discard result of while loop} - ; @r{by popping top of stack.} - ; @r{This result is the value @code{nil} that} - ; @r{was not popped by the goto at 9.} -@end group - -@group -18 varref t1 ; @r{Push value of @code{t1} onto stack.} -@end group - -@group -19 constant current-time-string ; @r{Push} +12 constant current-time-string ; @r{Push} ; @r{@code{current-time-string}} ; @r{onto top of stack.} @end group @group -20 call 0 ; @r{Call @code{current-time-string} again.} +13 call 0 ; @r{Call @code{current-time-string} again.} + +14 unbind 1 ; @r{Unbind @code{t1} in local environment.} @end group @group -21 list2 ; @r{Pop top two elements off stack,} +15 list2 ; @r{Pop top two elements off stack,} ; @r{create a list of them,} ; @r{and push list onto stack.} @end group @group -22 unbind 1 ; @r{Unbind @code{t1} in local environment.} - -23 return ; @r{Return value of the top of stack.} +16 return ; @r{Return the top element of the stack.} @result{} nil @end group diff --git a/man/lispref/errors.texi b/man/lispref/errors.texi index 109b9c8..d246f1b 100644 --- a/man/lispref/errors.texi +++ b/man/lispref/errors.texi @@ -87,6 +87,10 @@ This is a @code{file-error}.@* This is a @code{file-error}.@* @xref{Modification Time}. +@item invalid-byte-code +@code{"Invalid byte code"}@* +@xref{Byte Compilation}. + @item invalid-function @code{"Invalid function"}@* @xref{Classifying Lists}. diff --git a/man/lispref/hash-tables.texi b/man/lispref/hash-tables.texi index eccf794..ddf239b 100644 --- a/man/lispref/hash-tables.texi +++ b/man/lispref/hash-tables.texi @@ -7,8 +7,8 @@ @chapter Hash Tables @cindex hash table -@defun hashtablep object -This function returns non-@code{nil} if @var{object} is a hash table. +@defun hash-table-p object +This function returns @code{t} if @var{object} is a hash table, else @code{nil}. @end defun @menu @@ -23,77 +23,162 @@ This function returns non-@code{nil} if @var{object} is a hash table. @node Introduction to Hash Tables @section Introduction to Hash Tables -A hash table is a data structure that provides mappings from -arbitrary Lisp objects (called @dfn{keys}) to other arbitrary Lisp -objects (called @dfn{values}). There are many ways other than -hash tables of implementing the same sort of mapping, e.g. -association lists (@pxref{Association Lists}) and property lists -(@pxref{Property Lists}), but hash tables provide much faster lookup. - -When you create a hash table, you specify a size, which indicates the -expected number of elements that the table will hold. You are not -bound by this size, however; hash tables automatically resize themselves -if the number of elements becomes too large. - -(Internally, hash tables are hashed using a modification of the -@dfn{linear probing} hash table method. This method hashes each -key to a particular spot in the hash table, and then scans forward -sequentially until a blank entry is found. To look up a key, hash -to the appropriate spot, then search forward for the key until either -a key is found or a blank entry stops the search. The modification -actually used is called @dfn{double hashing} and involves moving forward -by a fixed increment, whose value is computed from the original hash -value, rather than always moving forward by one. This eliminates -problems with clustering that can arise from the simple linear probing -method. For more information, see @cite{Algorithms} (second edition) -by Robert Sedgewick, pp. 236-241.) - -@defun make-hashtable size &optional test-fun -This function makes a hash table of initial size @var{size}. Comparison -between keys is normally done with @code{eql}; i.e. two keys must be the -same object to be considered equivalent. However, you can explicitly -specify the comparison function using @var{test-fun}, which must be -one of @code{eq}, @code{eql}, or @code{equal}. - -Note that currently, @code{eq} and @code{eql} are the same. This will -change when bignums are implemented. +A @dfn{hash table} is a data structure that provides mappings from +arbitrary Lisp objects called @dfn{keys} to other arbitrary Lisp objects +called @dfn{values}. A key/value pair is sometimes called an +@dfn{entry} in the hash table. There are many ways other than hash +tables of implementing the same sort of mapping, e.g. association lists +(@pxref{Association Lists}) and property lists (@pxref{Property Lists}), +but hash tables provide much faster lookup when there are many entries +in the mapping. Hash tables are an implementation of the abstract data +type @dfn{dictionary}, also known as @dfn{associative array}. + +Internally, hash tables are hashed using the @dfn{linear probing} hash +table implementation method. This method hashes each key to a +particular spot in the hash table, and then scans forward sequentially +until a blank entry is found. To look up a key, hash to the appropriate +spot, then search forward for the key until either a key is found or a +blank entry stops the search. This method is used in preference to +double hashing because of changes in recent hardware. The penalty for +non-sequential access to memory has been increasing, and this +compensates for the problem of clustering that linear probing entails. + +When hash tables are created, the user may (but is not required to) +specify initial properties that influence performance. + +Use the @code{:size} parameter to specify the number of entries that are +likely to be stored in the hash table, to avoid the overhead of resizing +the table. But if the pre-allocated space for the entries is never +used, it is simply wasted and makes XEmacs slower. Excess unused hash +table entries exact a small continuous performance penalty, since they +must be scanned at every garbage collection. If the number of entries +in the hash table is unknown, simply avoid using the @code{:size} +keyword. + +Use the @code{:rehash-size} and @code{:rehash-threshold} keywords to +adjust the algorithm for deciding when to rehash the hash table. For +temporary hash tables that are going to be very heavily used, use a +small rehash threshold, for example, 0.4 and a large rehash size, for +example 2.0. For permanent hash tables that will be infrequently used, +specify a large rehash threshold, for example 0.8. + +Hash tables can also be created by the lisp reader using structure +syntax, for example: +@example +#s(hash-table size 20 data (foo 1 bar 2)) +@end example + +The structure syntax accepts the same keywords as @code{make-hash-table} +(without the @code{:} character), as well as the additional keyword +@code{data}, which specifies the initial hash table contents. + +@defun make-hash-table &key @code{:size} @code{:test} @code{:type} @code{:rehash-size} @code{:rehash-threshold} +This function returns a new empty hash table object. + +Keyword @code{:size} specifies the number of keys likely to be inserted. +This number of entries can be inserted without enlarging the hash table. + +Keyword @code{:test} can be @code{eq}, @code{eql} (default) or @code{equal}. +Comparison between keys is done using this function. +If speed is important, consider using @code{eq}. +When storing strings in the hash table, you will likely need to use @code{equal}. + +Keyword @code{:type} can be @code{non-weak} (default), @code{weak}, +@code{key-weak} or @code{value-weak}. + +A weak hash table is one whose pointers do not count as GC referents: +for any key-value pair in the hash table, if the only remaining pointer +to either the key or the value is in a weak hash table, then the pair +will be removed from the hash table, and the key and value collected. +A non-weak hash table (or any other pointer) would prevent the object +from being collected. + +A key-weak hash table is similar to a fully-weak hash table except that +a key-value pair will be removed only if the key remains unmarked +outside of weak hash tables. The pair will remain in the hash table if +the key is pointed to by something other than a weak hash table, even +if the value is not. + +A value-weak hash table is similar to a fully-weak hash table except +that a key-value pair will be removed only if the value remains +unmarked outside of weak hash tables. The pair will remain in the +hash table if the value is pointed to by something other than a weak +hash table, even if the key is not. + +Keyword @code{:rehash-size} must be a float greater than 1.0, and specifies +the factor by which to increase the size of the hash table when enlarging. + +Keyword @code{:rehash-threshold} must be a float between 0.0 and 1.0, +and specifies the load factor of the hash table which triggers enlarging. @end defun -@defun copy-hashtable old-table -This function makes a new hash table which contains the same keys and -values as the given table. The keys and values will not themselves be +@defun copy-hash-table hash-table +This function returns a new hash table which contains the same keys and +values as @var{hash-table}. The keys and values will not themselves be copied. @end defun -@defun hashtable-fullness table -This function returns number of entries in @var{table}. +@defun hash-table-count hash-table +This function returns the number of entries in @var{hash-table}. +@end defun + +@defun hash-table-size hash-table +This function returns the current number of slots in @var{hash-table}, +whether occupied or not. +@end defun + +@defun hash-table-type hash-table +This function returns the type of @var{hash-table}. +This can be one of @code{non-weak}, @code{weak}, @code{key-weak} or +@code{value-weak}. +@end defun + +@defun hash-table-test hash-table +This function returns the test function of @var{hash-table}. +This can be one of @code{eq}, @code{eql} or @code{equal}. +@end defun + +@defun hash-table-rehash-size hash-table +This function returns the current rehash size of @var{hash-table}. +This is a float greater than 1.0; the factor by which @var{hash-table} +is enlarged when the rehash threshold is exceeded. +@end defun + +@defun hash-table-rehash-threshold hash-table +This function returns the current rehash threshold of @var{hash-table}. +This is a float between 0.0 and 1.0; the maximum @dfn{load factor} of +@var{hash-table}, beyond which the @var{hash-table} is enlarged by rehashing. @end defun @node Working With Hash Tables @section Working With Hash Tables -@defun puthash key val table -This function hashes @var{key} to @var{val} in @var{table}. +@defun puthash key value hash-table +This function hashes @var{key} to @var{value} in @var{hash-table}. @end defun -@defun gethash key table &optional default -This function finds the hash value for @var{key} in @var{table}. If -there is no corresponding value, @var{default} is returned (defaults to -@code{nil}). +@defun gethash key hash-table &optional default +This function finds the hash value for @var{key} in @var{hash-table}. +If there is no entry for @var{key} in @var{hash-table}, @var{default} is +returned (which in turn defaults to @code{nil}). @end defun -@defun remhash key table -This function removes the hash value for @var{key} in @var{table}. +@defun remhash key hash-table +This function removes the entry for @var{key} from @var{hash-table}. +Does nothing if there is no entry for @var{key} in @var{hash-table}. @end defun -@defun clrhash table -This function flushes @var{table}. Afterwards, the hash table will -contain no entries. +@defun clrhash hash-table +This function removes all entries from @var{hash-table}, leaving it empty. @end defun -@defun maphash function table -This function maps @var{function} over entries in @var{table}, calling -it with two args, each key and value in the table. +@defun maphash function hash-table +This function maps @var{function} over entries in @var{hash-table}, +calling it with two args, each key and value in the hash table. + +@var{function} may not modify @var{hash-table}, with the one exception +that @var{function} may remhash or puthash the entry currently being +processed by @var{function}. @end defun @node Weak Hash Tables @@ -135,17 +220,5 @@ of the table, regardless of how the key is referenced. Also see @ref{Weak Lists}. -@defun make-weak-hashtable size &optional test-fun -This function makes a fully weak hash table of initial size @var{size}. -@var{test-fun} is as in @code{make-hashtable}. -@end defun - -@defun make-key-weak-hashtable size &optional test-fun -This function makes a key-weak hash table of initial size @var{size}. -@var{test-fun} is as in @code{make-hashtable}. -@end defun - -@defun make-value-weak-hashtable size &optional test-fun -This function makes a value-weak hash table of initial size @var{size}. -@var{test-fun} is as in @code{make-hashtable}. -@end defun +Weak hash tables are created by specifying the @code{:type} keyword to +@code{make-hash-table}. diff --git a/man/lispref/macros.texi b/man/lispref/macros.texi index ba3c12b..92c6dbf 100644 --- a/man/lispref/macros.texi +++ b/man/lispref/macros.texi @@ -282,14 +282,14 @@ Here are some examples: @end group @end example -@quotation -Before Emacs version 19.29, @samp{`} used a different syntax which -required an extra level of parentheses around the entire backquote -construct. Likewise, each @samp{,} or @samp{,@@} substitution required an -extra level of parentheses surrounding both the @samp{,} or @samp{,@@} -and the following expression. The old syntax required whitespace -between the @samp{`}, @samp{,} or @samp{,@@} and the following -expression. +@quotation +In older versions of Emacs (before XEmacs 19.12 or FSF Emacs version +19.29), @samp{`} used a different syntax which required an extra level +of parentheses around the entire backquote construct. Likewise, each +@samp{,} or @samp{,@@} substitution required an extra level of +parentheses surrounding both the @samp{,} or @samp{,@@} and the +following expression. The old syntax required whitespace between the +@samp{`}, @samp{,} or @samp{,@@} and the following expression. This syntax is still accepted, but no longer recommended except for compatibility with old Emacs versions. diff --git a/man/lispref/objects.texi b/man/lispref/objects.texi index 97ab831..e3eca51 100644 --- a/man/lispref/objects.texi +++ b/man/lispref/objects.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the XEmacs Lisp Reference Manual. -@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. @c See the file lispref.texi for copying conditions. @setfilename ../../info/objects.info @node Lisp Data Types, Numbers, Introduction, Top @@ -26,7 +26,7 @@ which all other types are constructed, are called @dfn{primitive types}. Each object belongs to one and only one primitive type. These types include @dfn{integer}, @dfn{character} (starting with XEmacs 20.0), @dfn{float}, @dfn{cons}, @dfn{symbol}, @dfn{string}, @dfn{vector}, -@dfn{bit-vector}, @dfn{subr}, @dfn{compiled-function}, @dfn{hashtable}, +@dfn{bit-vector}, @dfn{subr}, @dfn{compiled-function}, @dfn{hash-table}, @dfn{range-table}, @dfn{char-table}, @dfn{weak-list}, and several special types, such as @dfn{buffer}, that are related to editing. (@xref{Editing Types}.) @@ -173,7 +173,7 @@ frame @item glyph @item -hashtable +hash-table @item image-instance @item @@ -407,7 +407,7 @@ provides for characters. The usual read syntax for alphanumeric characters is a question mark followed by the character; thus, @samp{?A} for the character @kbd{A}, @samp{?B} for the character @kbd{B}, and @samp{?a} for the -character @kbd{a}. +character @kbd{a}. For example: @@ -1051,8 +1051,8 @@ ignores an escaped newline while reading a string. in documentation strings, but the newline is \ ignored if escaped." - @result{} "It is useful to include newlines -in documentation strings, + @result{} "It is useful to include newlines +in documentation strings, but the newline is ignored if escaped." @end example @@ -1253,17 +1253,22 @@ called @dfn{hashing}. Hash tables are very fast (much more efficient that using an association list, when there are a large number of elements in the table). - Hash tables have no read syntax. They print in hash notation (The -``hash'' in ``hash notation'' has nothing to do with the ``hash'' in -``hash table''), giving the number of elements, total space allocated -for elements, and a unique number assigned at the time the hash table -was created. (Hash tables automatically resize as necessary so there -is no danger of running out of space for elements.) +Hash tables have a special read syntax beginning with +@samp{#s(hash-table} (this is an example of @dfn{structure} read +syntax. This notation is also used for printing when +@code{print-readably} is @code{t}. + +Otherwise they print in hash notation (The ``hash'' in ``hash notation'' +has nothing to do with the ``hash'' in ``hash table''), giving the +number of elements, total space allocated for elements, and a unique +number assigned at the time the hash table was created. (Hash tables +automatically resize as necessary so there is no danger of running out +of space for elements.) @example @group -(make-hashtable 50) - @result{} # +(make-hash-table :size 50) + @result{} # @end group @end example @@ -1983,8 +1988,8 @@ with references to further information. @item glyphp @xref{Glyphs, glyphp}. -@item hashtablep -@xref{Hash Tables, hashtablep}. +@item hash-table-p +@xref{Hash Tables, hash-table-p}. @item icon-glyph-p @xref{Glyph Types, icon-glyph-p}. @@ -2153,7 +2158,7 @@ This function returns a symbol naming the primitive type of @code{coding-system}, @code{cons}, @code{color-instance}, @code{compiled-function}, @code{console}, @code{database}, @code{device}, @code{event}, @code{extent}, @code{face}, @code{float}, -@code{font-instance}, @code{frame}, @code{glyph}, @code{hashtable}, +@code{font-instance}, @code{frame}, @code{glyph}, @code{hash-table}, @code{image-instance}, @code{integer}, @code{keymap}, @code{marker}, @code{process}, @code{range-table}, @code{specifier}, @code{string}, @code{subr}, @code{subwindow}, @code{symbol}, @code{toolbar-button}, diff --git a/man/widget.texi b/man/widget.texi index dbcbcad..367ebd0 100644 --- a/man/widget.texi +++ b/man/widget.texi @@ -670,7 +670,7 @@ Syntax: TYPE ::= (info-link [KEYWORD ARGUMENT]... ADDRESS) @end example -When this link is invoked, the build-in info browser is started on +When this link is invoked, the built-in info browser is started on @var{address}. @node push-button, editable-field, info-link, Basic Types diff --git a/man/xemacs-faq.texi b/man/xemacs-faq.texi index 0764448..cc3c90f 100644 --- a/man/xemacs-faq.texi +++ b/man/xemacs-faq.texi @@ -7,7 +7,7 @@ @finalout @titlepage @title XEmacs FAQ -@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 1998/06/30 06:35:33 $ +@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 1998/12/05 16:55:03 $ @sp 1 @author Tony Rossini @author Ben Wing @@ -64,7 +64,7 @@ The canonical version of the FAQ is the texinfo document @item If you do not have makeinfo installed, you may @uref{xemacs-faq.info, download the faq} in info format, and install it in @file{/info/}. For example in +library directory>/info/}. For example in @file{/usr/local/lib/xemacs-20.4/info/}. @end itemize @@ -2727,7 +2727,7 @@ It's almost always a mistake to test @code{emacs-version} or any similar variables. Instead, use feature-tests, such as @code{featurep}, @code{boundp}, -@code{fboundp}, or even simple behavioural tests, eg.: +@code{fboundp}, or even simple behavioral tests, eg.: @lisp (defvar foo-old-losing-code-p diff --git a/man/xemacs/custom.texi b/man/xemacs/custom.texi index 9a8dc9b..f5c20ce 100644 --- a/man/xemacs/custom.texi +++ b/man/xemacs/custom.texi @@ -2481,7 +2481,7 @@ XEmacs executable (usually @samp{xemacs}), and @node Menubar Resources @subsection Menubar Resources -As the menubar is implemented as a widget which is not a part of XEacs +As the menubar is implemented as a widget which is not a part of XEmacs proper, it does not use the fac" mechanism for specifying fonts and colors: It uses whatever resources are appropriate to the type of widget which is used to implement it. diff --git a/man/xemacs/startup.texi b/man/xemacs/startup.texi index a3d488e..54ab1b3 100644 --- a/man/xemacs/startup.texi +++ b/man/xemacs/startup.texi @@ -22,15 +22,15 @@ installation itself. However, there are several views of what actually constitutes the "XEmacs installation": XEmacs may be run from the compilation directory, it may be installed into arbitrary directories, spread over several directories unrelated to each other. Moreover, it -may subsequently moved to a different place. (This last case is not as -uncommon as it sounds. Binary kits work this way.) Consequently, +may subsequently be moved to a different place. (This last case is not +as uncommon as it sounds. Binary kits work this way.) Consequently, XEmacs has quite complex procedures in place to find directories, no matter where they may be hidden. XEmacs will always respect directory options passed to @code{configure}. However, if it cannot locate a directory at the configured place, it will initiate a search for the directory in any of a number of -@dfn{hierachies} rooted under a directory which XEmacs assumes contain +@dfn{hierarchies} rooted under a directory which XEmacs assumes contain parts of the XEmacs installation; it may locate several such hierarchies and search across them. (Typically, there are just one or two hierarchies: the hierarchy where XEmacs was or will be installed, and diff --git a/nt/ChangeLog b/nt/ChangeLog index 4a04b57..438f5e4 100644 --- a/nt/ChangeLog +++ b/nt/ChangeLog @@ -1,3 +1,7 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff --git a/src/ChangeLog b/src/ChangeLog index 765c3bf..655559a 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,705 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + +1998-11-30 Martin Buchholz + + * xselect.c (receive_incremental_selection): + * xselect.c (x_get_window_property): + * xmu.c (XmuReadBitmapDataFromFile): + * xmu.c (XmuCursorNameToIndex): + * xgccache.c (describe_gc_cache): + * xgccache.c (gc_cache_lookup): + * xgccache.c (free_gc_cache): + * xgccache.c (make_gc_cache): + * window.h: + * window.c (map_windows_1): + * window.c (Fother_window_for_scrolling): + * window.c (window_scroll): + * window.c (change_window_height): + * window.c (Fsplit_window): + * window.c (window_left_gutter_width): + * window.c (window_modeline_height): + * window.c (invalidate_vertical_divider_cache_in_window): + * window.c (window_needs_vertical_divider_1): + * window.c (update_mirror_internal): + * window.c (SET_LAST_FACECHANGE): + * widget.c (Fwidget_plist_member): + * unexec.c (copy_text_and_data): + * unexcw.c (copy_executable_and_dump_data_section): + * tooltalk.doc: + * tooltalk.c (struct Lisp_Tooltalk_Pattern): + * tooltalk.c (struct Lisp_Tooltalk_Message): + * toolbar.h (struct toolbar_button): + * toolbar.c (default_toolbar_visible_p_changed_in_window): + * toolbar.c (recompute_overlaying_specifier): + * toolbar.c (toolbar_validate): + * toolbar.c (toolbar_button_at_pixpos): + * toolbar.c (get_toolbar_coords): + * toolbar.c (update_frame_toolbars): + * toolbar-x.c: + * toolbar-msw.c (mswindows_handle_toolbar_wm_command): + * toolbar-msw.c (mswindows_find_toolbar_pos): + * toolbar-msw.c (mswindows_output_toolbar): + * toolbar-msw.c (mswindows_clear_toolbar): + * toolbar-msw.c: + * systty.h: + * syssignal.h: + * sysproc.h: + * sysfile.h: + * sysdll.c: + * sysdep.h: + * sysdep.c (rmdir): + * sysdep.c (sys_fopen): + * sysdep.c (sys_open): + * sysdep.c (tty_init_sys_modes_on_device): + * sysdep.c (get_eof_char): + * sysdep.c (child_setup_tty): + * sysdep.c (set_descriptor_non_blocking): + * syntax.h: + * syntax.c (scan_words): + * syntax.c: + * symsinit.h: + * symeval.h (struct symbol_value_varalias): + * symeval.h (struct symbol_value_forward): + * symbols.c (syms_of_symbols): + * symbols.c (init_symbols_once_early): + * symbols.c (Fbuilt_in_variable_type): + * symbols.c (Fsymbol_value_in_buffer): + * symbols.c (default_value): + * symbols.c (Fset): + * symbols.c (find_symbol_value_quickly): + * symbols.c (store_symval_forwarding): + * symbols.c (set_default_console_slot_variable): + * symbols.c (set_default_buffer_slot_variable): + * symbols.c (verify_ok_for_buffer_local): + * symbols.c (symbol_is_constant): + * symbols.c (oblookup): + * symbols.c (Funintern): + * symbols.c (Fintern): + * symbols.c (check_obarray): + * sunplay.c: + * specifier.h (struct specifier_methods): + * specifier.h: + * specifier.c (specifier_instance): + * specifier.c (specifier_instance_from_inst_list): + * specifier.c (decode_locale_type): + * specifier.c (specifier_equal): + * specifier.c (finalize_specifier): + * specifier.c (prune_specifiers): + * specifier.c (kill_specifier_buffer_locals): + * sound.c (init_native_sound): + * sound.c: + * signal.c (alarm): + * search.c (Fmatch_data): + * search.c (match_limit): + * search.c (Freplace_match): + * search.c (skip_chars): + * search.c (scan_buffer): + * search.c: + * scrollbar.c (specifier_vars_of_scrollbar): + * scrollbar.c (Fscrollbar_set_hscroll): + * scrollbar.c (vertical_scrollbar_changed_in_window): + * scrollbar.c (release_window_mirror_scrollbars): + * scrollbar.c (free_scrollbar_instance): + * scrollbar-x.c: + * scrollbar-msw.c: + * s/msdos.h (O_BINARY): + * s/linux.h: + * s/freebsd.h (LIBS_TERMCAP): + * regex.c (re_match_2_internal): + * regex.c (compile_extended_range): + * regex.c (POP_FAILURE_POINT): + * regex.c (PUSH_FAILURE_POINT): + * redisplay.h (RESET_CHANGED_SET_FLAGS): + * redisplay.h: + * redisplay.h (struct display_line): + * redisplay.h (struct rune): + * redisplay.c (vars_of_redisplay): + * redisplay.c (redisplay_variable_changed): + * redisplay.c (UPDATE_CACHE_RETURN): + * redisplay.c (validate_line_start_cache): + * redisplay.c (mark_redisplay_structs): + * redisplay.c (mark_glyph_block_dynarr): + * redisplay.c (window_line_number): + * redisplay.c (redisplay_frame): + * redisplay.c (redisplay_window): + * redisplay.c (generate_modeline): + * redisplay.c (create_right_glyph_block): + * redisplay.c (create_left_glyph_block): + * redisplay.c (create_text_block): + * redisplay.c: + * redisplay-x.c (x_output_hline): + * redisplay-x.c (x_output_vertical_divider): + * redisplay-tty.c (tty_output_display_block): + * redisplay-output.c (output_display_line): + * redisplay-output.c: + * redisplay-msw.c (mswindows_output_vertical_divider): + * redisplay-msw.c (mswindows_ring_bell): + * redisplay-msw.c (mswindows_output_cursor): + * redisplay-msw.c: + * rangetab.c: + * ralloc.c: + * puresize.h (RAW_PURESIZE): + * profile.c (syms_of_profile): + * profile.c (Fstart_profiling): + * profile.c (sigprof_handler): + * profile.c: + * procimpl.h: + * process.c (vars_of_process): + * process.c (read_process_output): + * process.c (get_process): + * process.c: + * process-unix.c (unix_open_multicast_group): + * process-unix.c (unix_get_tty_name): + * process-unix.c (unix_send_process): + * process-unix.c (unix_reap_exited_processes): + * process-unix.c (unix_create_process): + * process-unix.c (unix_init_process_io_handles): + * process-unix.c (allocate_pty): + * process-unix.c: + * process-nt.c (nt_open_network_stream): + * process-nt.c (nt_update_status_if_terminated): + * process-nt.c (nt_finalize_process_data): + * process-nt.c: + * print.c (debug_short_backtrace): + * print.c (debug_backtrace): + * print.c (print_symbol): + * print.c (print_internal): + * print.c (print_cons): + * print.c (Fwrite_char): + * print.c (print_prepare): + * print.c (canonicalize_printcharfun): + * print.c (output_string): + * print.c: + * opaque.h: + * opaque.c (allocate_managed_opaque): + * opaque.c: + * offix.c (DndSetData): + * objects.c (face_boolean_create): + * objects.c (font_instantiate): + * objects.c (font_create): + * objects.c (color_create): + * objects.c (finalize_font_instance): + * objects.c (finalize_color_instance): + * objects.c: + * objects-x.c (x_font_instance_truename): + * objects-x.c: + * objects-x.c (x_initialize_font_instance): + * objects-x.c (allocate_nearest_color): + * objects-tty.c (tty_initialize_font_instance): + * objects-tty.c (tty_initialize_color_instance): + * objects-msw.c (mswindows_initialize_color_instance): + * ntproc.c (syms_of_ntproc): + * ntproc.c (Fwin32_set_process_priority): + * ntproc.c (sys_spawnve): + * ntproc.c: + * ntheap.c (get_data_end): + * nt.c (period): + * nt.c: + * nt.c (stat): + * nt.c (generate_inode_val): + * nt.c (sys_rename): + * nas.c: + * mule-wnnfns.c (Fwnn_hinsi_number): + * mule-wnnfns.c (Fwnn_yuragi): + * mule-wnnfns.c (Fwnn_common_learn): + * mule-wnnfns.c (Fwnn_suffix_learn): + * mule-wnnfns.c (Fwnn_prefix_learn): + * mule-wnnfns.c (Fwnn_okuri_learn): + * mule-wnnfns.c (Fwnn_complex_conv): + * mule-wnnfns.c (Fwnn_last_is_first): + * mule-wnnfns.c (Fwnn_bmodify_dict_add): + * mule-wnnfns.c (Fwnn_notrans_dict_add): + * mule-wnnfns.c (Fwnn_fiusr_dict_add): + * mule-wnnfns.c (Fwnn_fisys_dict_add): + * mule-wnnfns.c (Fwnn_hinsi_list): + * mule-wnnfns.c (Fwnn_fuzokugo_set): + * mule-wnnfns.c (Fwnn_dict_search): + * mule-wnnfns.c (Fwnn_word_toroku): + * mule-wnnfns.c (Fwnn_hindo_update): + * mule-wnnfns.c (Fwnn_bunsetu_henkou): + * mule-wnnfns.c (Fwnn_kakutei): + * mule-wnnfns.c (Fwnn_begin_henkan): + * mule-wnnfns.c (Fwnn_dict_comment): + * mule-wnnfns.c (Fwnn_dict_add): + * mule-wnnfns.c (Fwnn_open): + * mule-mcpath.c (mc_getcwd): + * mule-coding.c (vars_of_mule_coding): + * mule-coding.c (convert_to_external_format): + * mule-coding.c (encoding_marker): + * mule-coding.c (decoding_marker): + * mule-coding.c (Fcopy_coding_system): + * mule-coding.c (Fmake_coding_system): + * mule-coding.c (Fcoding_system_list): + * mule-coding.c (Ffind_coding_system): + * mule-coding.c (symbol_to_eol_type): + * mule-coding.c: + * mule-charset.c (complex_vars_of_mule_charset): + * mule-charset.c (vars_of_mule_charset): + * mule-charset.c (Fset_charset_ccl_program): + * mule-charset.c (struct charset_list_closure): + * mule-charset.c (Ffind_charset): + * mule-charset.c (make_charset): + * mule-charset.c (non_ascii_valid_char_p): + * mule-charset.c: + * mule-ccl.c (ccl_driver): + * mule-canna.c (c2mu): + * mule-canna.c (Fcanna_henkan_begin): + * mule-canna.c (Fcanna_parse): + * mule-canna.c (Fcanna_store_yomi): + * mule-canna.c (Fcanna_touroku_string): + * mule-canna.c (Fcanna_initialize): + * minibuf.c: + * menubar.c (menu_parse_submenu_keywords): + * menubar-x.c (make_dummy_xbutton_event): + * menubar-x.c (set_frame_menubar): + * menubar-x.c (menu_item_descriptor_to_widget_value_1): + * menubar-x.c: + * menubar-msw.h: + * menubar-msw.c (mswindows_popup_menu): + * menubar-msw.c (mswindows_update_frame_menubars): + * menubar-msw.c (mswindows_handle_wm_command): + * menubar-msw.c (unsafe_handle_wm_initmenu_1): + * menubar-msw.c (unsafe_handle_wm_initmenupopup_1): + * menubar-msw.c (update_frame_menubar_maybe): + * menubar-msw.c (populate_or_checksum_helper): + * menubar-msw.c (empty_menu): + * menubar-msw.c: + * md5.c: + * marker.c (set_marker_internal): + * marker.c (print_marker): + * malloc.c: + * make-src-depend: + * lstream.c (lisp_buffer_rewinder): + * lstream.c (mark_lstream): + * lrecord.h: + * lrecord.h (struct lrecord_header): + * lread.c (readevalloop): + * lread.c (locate_file): + * lread.c (locate_file_in_directory): + * lread.c (Flocate_file): + * lread.c (load_force_doc_string_unwind): + * lread.c (ebolify_bytecode_constants): + * lread.c: + * lisp.h: + * lisp-union.h: + * lisp-disunion.h: + * linuxplay.c (linux_play_data_or_file): + * linuxplay.c (audio_init): + * line-number.c: + * keymap.h: + * keymap.c (describe_map): + * keymap.c (describe_map_mapper): + * keymap.c (Fdescribe_bindings_internal): + * keymap.c (Fsingle_key_description): + * keymap.c (map_keymap_sorted): + * keymap.c (get_relevant_keymaps): + * keymap.c (Flookup_key): + * keymap.c (raw_lookup_key_mapper): + * keymap.c (Fdefine_key): + * keymap.c (Fevent_matches_key_specifier_p): + * keymap.c (key_desc_list_to_event): + * keymap.c (define_key_parser): + * keymap.c (define_key_check_and_coerce_keysym): + * keymap.c (keymap_submaps): + * keymap.c (keymap_store_internal): + * keymap.c (keymap_delete_inverse_internal): + * keymap.c (keymap_store_inverse_internal): + * keymap.c (print_keymap): + * keymap.c (Lisp_Keymap): + * keymap.c: + * intl.c: + * insdel.c (convert_bufbyte_string_into_emchar_dynarr): + * insdel.c (make_gap): + * input-method-xlib.c (get_XIM_input): + * input-method-xlib.c (XIM_init_frame): + * imgproc.c: + * hash.h: + * hash.c: + * gui.c: + * gui-x.c (button_item_to_widget_value): + * gui-x.c (popup_selection_callback): + * glyphs.h (struct image_instantiator_methods): + * glyphs.c (mark_glyph_cachels): + * glyphs.c (Fglyph_type): + * glyphs.c (image_instantiate): + * glyphs.c (image_create): + * glyphs.c (make_image_instance_1): + * glyphs.c (finalize_image_instance): + * glyphs.c: + * glyphs-x.c (finalize_subwindow): + * glyphs-x.c (xface_validate): + * glyphs-x.c (x_locate_pixmap_file): + * glyphs-x.c (convert_EImage_to_XImage): + * glyphs-msw.c: + * glyphs-msw.c (mswindows_resource_instantiate): + * glyphs-msw.c (xpm_to_eimage): + * glyphs-msw.c (convert_EImage_to_DIBitmap): + * glyphs-eimage.c (tiff_instantiate): + * glyphs-eimage.c (png_instantiate): + * glyphs-eimage.c (struct png_error_struct): + * glyphs-eimage.c (gif_memory_storage): + * glyphs-eimage.c: + * gifrlib.h: + * getloadavg.c (getloadavg): + * getloadavg.c: + * gdbinit: + * free-hook.c (log_gcpro): + * free-hook.c (check_malloc): + * free-hook.c (check_free): + * free-hook.c (ROUND_UP_TO_PAGE): + * free-hook.c: + * frame.h (struct frame): + * frame.h: + * frame.c (change_frame_size_1): + * frame.c (allocate_frame_core): + * frame.c: + * frame-x.c (x_focus_on_frame): + * frame-x.c (x_init_frame_2): + * frame-x.c (x_popup_frame): + * frame-x.c (xemacs_XtPopup): + * frame-x.c: + * frame-x.c (Foffix_start_drag_internal): + * frame-x.c (x_cde_destroy_callback): + * frame-x.c (x_wm_hack_wm_protocols): + * frame-tty.c (tty_frame_visible_p): + * frame-msw.c (mswindows_make_frame_invisible): + * frame-msw.c (mswindows_after_init_frame): + * frame-msw.c (mswindows_init_frame_1): + * fns.c (syms_of_fns): + * fns.c (Fbase64_decode_string): + * fns.c (Fnconc): + * fns.c (Ffillarray): + * fns.c (Fobject_plist): + * fns.c (Fget): + * fns.c (Fcanonicalize_lax_plist): + * fns.c (Fcanonicalize_plist): + * fns.c (Fplist_remprop): + * fns.c (Fplist_get): + * fns.c (advance_plist_pointers): + * fns.c (internal_plist_put): + * fns.c (Fnreverse): + * fns.c (Fremassq): + * fns.c (Felt): + * fns.c (Fsubstring): + * fns.c (Fbvconcat): + * fns.c (Flength): + * fns.c (length_with_bytecode_hack): + * fns.c (print_bit_vector): + * fns.c: + * floatfns.c (Ffloor): + * floatfns.c: + * floatfns.c (in_float_error): + * fileio.c (Ffile_modes): + * fileio.c (Fexpand_file_name): + * fileio.c (Fmake_temp_name): + * fileio.c (Ffile_name_nondirectory): + * fileio.c (Ffile_name_directory): + * file-coding.h: + * file-coding.c (vars_of_mule_coding): + * file-coding.c (convert_to_external_format): + * file-coding.c (encoding_marker): + * file-coding.c (decoding_marker): + * file-coding.c (Fcopy_coding_system): + * file-coding.c (Fmake_coding_system): + * file-coding.c (struct coding_system_list_closure): + * file-coding.c (Ffind_coding_system): + * file-coding.c (symbol_to_eol_type): + * file-coding.c: + * faces.h (struct face_cachel): + * faces.c (vars_of_faces): + * faces.c (face_property_was_changed): + * faces.c (mark_face_cachels): + * faces.c (temporary_faces_list): + * faces.c (struct face_list_closure): + * faces.c: + * extents.h (struct extent): + * extents.c (vars_of_extents): + * extents.c (struct copy_string_extents_1_arg): + * extents.c (add_string_extents_mapper): + * extents.c (Fextent_property): + * extents.c (Fset_extent_property): + * extents.c (symbol_to_glyph_layout): + * extents.c (properties_equal): + * extents.c (print_extent): + * extents.c (print_extent_1): + * extents.c (extent_in_region_p): + * extents.c (gap_array_make_gap): + * extents.c: + * events.h (struct Lisp_Event): + * events.h: + * events.c (Fevent_properties): + * events.c (format_event_object): + * events.c (Fmake_event): + * events.c (event_equal): + * events.c (print_event): + * events.c (mark_event): + * event-stream.c ((read-char) + * event-stream.c (vars_of_event_stream): + * event-stream.c (syms_of_event_stream): + * event-stream.c (Fset_recent_keys_ring_size): + * event-stream.c (Fsit_for): + * event-stream.c (Fnext_event): + * event-stream.c (execute_help_form): + * event-stream.c (maybe_kbd_translate): + * event-stream.c: + * event-msw.c (vars_of_event_mswindows): + * event-msw.c (mswindows_wnd_proc): + * event-msw.c (mswindows_need_event): + * event-msw.c (mswindows_drain_windows_queue): + * event-msw.c (mswindows_pump_outstanding_events): + * event-msw.c: + * event-msw.c (slurp_thread): + * event-msw.c (struct ntpipe_slurp_stream): + * event-msw.c (HANDLE_TO_USID): + * event-Xt.c (emacs_Xt_handle_magic_event): + * event-Xt.c (x_event_to_emacs_event): + * event-Xt.c (x_reset_modifier_mapping): + * event-Xt.c (x_reset_key_mapping): + * event-Xt.c: + * eval.c (syms_of_eval): + * eval.c (warn_when_safe): + * eval.c (warn_when_safe_lispobj): + * eval.c (Fbacktrace_frame): + * eval.c (Fbacktrace): + * eval.c (top_level_set): + * eval.c (unbind_to_hairy): + * eval.c (specbind_magic): + * eval.c (specbind_unwind_wasnt_local): + * eval.c (call2_trapping_errors): + * eval.c (call1_trapping_errors): + * eval.c (catch_them_squirmers_call2): + * eval.c (call0_trapping_errors): + * eval.c (run_hook_trapping_errors): + * eval.c (catch_them_squirmers_eval_in_buffer): + * eval.c (call4_in_buffer): + * eval.c (call3_in_buffer): + * eval.c (call2_in_buffer): + * eval.c (call1_in_buffer): + * eval.c (call0_in_buffer): + * eval.c (run_hook): + * eval.c (run_hook_with_args_in_buffer): + * eval.c (Fapply): + * eval.c (Feval): + * eval.c (do_autoload): + * eval.c (un_autoload): + * eval.c (Fautoload): + * eval.c (Finteractive_p): + * eval.c (Fcommand_execute): + * eval.c (signal_quit): + * eval.c (call_with_suspended_errors): + * eval.c (signal_error): + * eval.c (return_from_signal): + * eval.c (Fcall_with_condition_handler): + * eval.c (run_condition_case_handlers): + * eval.c (condition_case_1): + * eval.c (Funwind_protect): + * eval.c (unwind_to_catch): + * eval.c (internal_catch): + * eval.c (Fmacroexpand_internal): + * eval.c (Fuser_variable_p): + * eval.c (Fdefconst): + * eval.c (Fdefvar): + * eval.c (Ffunction): + * eval.c (signal_call_debugger): + * eval.c (call_debugger): + * eval.c: + * emacs.c (main): + * emacs.c (sort_args): + * emacs.c (main_1): + * elhash.h: + * elhash.c: + * editfns.c (Fencode_time): + * editfns.c (Fdecode_time): + * editfns.c (Fuser_full_name): + * editfns.c: + * editfns.c (save_excursion_restore): + * ecrt0.c: + * dynarr.c: + * doprnt.c (emacs_doprnt_1): + * doc.c (verify_doc_mapper): + * doc.c (Fsnarf_documentation): + * doc.c (Fdocumentation): + * dll.c: + * dired.c (user_name_completion): + * dired.c (Fdirectory_files): + * dialog-x.c: + * dialog-msw.c: + * dgif_lib.c (FreeSavedImages): + * dgif_lib.c (DGifGetImageDesc): + * device.h: + * device.h (struct device): + * device.c (Fselect_device): + * device.c (allocate_device): + * device.c: + * device-x.c (Fx_keysym_on_keyboard_p): + * device-x.c (Fx_valid_keysym_name_p): + * device-x.c (x_IO_error_handler): + * device-x.c (x_delete_device): + * device-x.c (x_finish_init_device): + * device-x.c (x_init_device): + * device-x.c: + * device-msw.c (mswindows_init_device): + * dbxrc: + * database.c (vars_of_database): + * database.c (Fput_database): + * database.c (Fopen_database): + * database.c (berkdb_remove): + * database.c (berkdb_put): + * database.c (Fdatabasep): + * database.c (print_database): + * database.c: + * data.c (vars_of_data): + * data.c (syms_of_data): + * data.c (init_errors_once_early): + * data.c (prune_weak_lists): + * data.c (finish_marking_weak_lists): + * data.c (print_weak_list): + * data.c (Fmod): + * data.c (Fstring_to_number): + * data.c (Fnumber_to_string): + * data.c (Findirect_function): + * data.c (Fsetcdr): + * data.c (Ffloatp): + * data.c (Fsubr_interactive): + * data.c (Farrayp): + * data.c (Fkeywordp): + * data.c (Fnull): + * data.c: + * console.h (CONSOLE_NAME): + * console.h: + * console.c (vars_of_console): + * console.c (Fselect_console): + * console.c: + * console-x.h (DEVICE_X_COLORMAP): + * console-x.h (struct x_device): + * console-x.c (x_device_to_console_connection): + * console-tty.h (CONSOLE_TTY_FINAL_CURSOR_Y): + * console-tty.c (tty_init_console): + * console-tty.c: + * console-msw.h (struct mswindows_frame): + * conslots.h: + * config.h.in: + * cmds.c (internal_self_insert): + * cmds.c (Fforward_line): + * cmds.c (Fforward_char): + * cmds.c: + * cmdloop.c: + * chartab.c (mark_char_table_entry): + * chartab.c: + * casefiddle.c (casify_word): + * callproc.c (child_setup): + * callproc.c (Fcall_process_internal): + * callproc.c: + * callint.c (Fcall_interactively): + * bytecode.h: + * bytecode.c (execute_rare_opcode): + * bytecode.c (execute_optimized_program): + * bytecode.c: + * bufslots.h: + * buffer.h (BUFFER_REALLOC): + * buffer.h (GET_CHARPTR_INT_DATA_ALLOCA): + * buffer.h (GET_CHARPTR_EXT_DATA_ALLOCA): + * buffer.h: + * buffer.h (MAP_INDIRECT_BUFFERS): + * buffer.h (CHECK_LIVE_BUFFER): + * buffer.c (init_initial_directory): + * buffer.c (complex_vars_of_buffer): + * buffer.c (vars_of_buffer): + * buffer.c (finish_init_buffer): + * buffer.c (Fget_file_buffer): + * buffer.c (Fbuffer_list): + * buffer.c (mark_buffer): + * balloon_help.c (balloon_help_move_to_pointer): + * balloon_help.c (show_help): + * balloon_help.c: + * backtrace.h: + * alloc.c (garbage_collect_1): + * alloc.c (sweep_strings): + * alloc.c (sweep_compiled_functions): + * alloc.c (sweep_bit_vectors_1): + * alloc.c (sweep_vectors_1): + * alloc.c (sweep_lcrecords_1): + * alloc.c (tick_lcrecord_stats): + * alloc.c (pure_string_sizeof): + * alloc.c (mark_conses_in_list): + * alloc.c (mark_object): + * alloc.c (report_pure_usage): + * alloc.c (make_pure_float): + * alloc.c (make_pure_string): + * alloc.c (free_managed_lcrecord): + * alloc.c (mark_string): + * alloc.c (noseeum_make_marker): + * alloc.c (allocate_event): + * alloc.c (Fbit_vector): + * alloc.c (Fvector): + * alloc.c (make_float): + * alloc.c (Fmake_list): + * alloc.c (Flist): + * alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC): + * alloc.c (PUT_FIXED_TYPE_ON_FREE_LIST): + * alloc.c (DECLARE_FIXED_TYPE_ALLOC): + * alloc.c (dbg_constants): + * alloc.c (gc_record_type_p): + * alloc.c (free_lcrecord): + * alloc.c (xmalloc): + * alloc.c (NOSEEUM_INCREMENT_CONS_COUNTER): + * abbrev.c: + * Makefile.in.in (mostlyclean): + * Makefile.in.in (external_client_xlib_objs_nonshared): + * Makefile.in.in (temacs_link_args): + * Makefile.in.in (release): + * Makefile.in.in (dnd_objs): + * Makefile.in.in (objs): + * Makefile.in.in (PROGNAME): + * EmacsShell.c: cast strings to (XtPointer) + * EmacsFrame.c: cast strings to (XtPointer) + - mega patch + - rewrite basic lisp functions for speed + - rewrite bytecode interpreter for speed + - rewrite list looping constructs for speed and safety using + tortoise/hare. + - use size_t where appropriate. + - new hashtable implementation + - cleanup implementation of opaques + - opaques can now be purecopy'ed + - move some cl functionality into C for speed. + - remove last remaining VMS support + - spelling fixes + - improve gdb/dbx debugger support + - move pure.c back into alloc.c for performance + - enable report_pure_usage() if --memory-usage-stats + - remove remnants of Energize support (EMACS_BTL, cadillac...) + - don't use symbols with leading `_' or embedded `__' + - globally cleanup duplicated semicolons `;;' + - I give in on %p vs %lx - we use printf("%lx",(long) p) + globally. + - globally replace O_NDELAY with O_NONBLOCK. + - globally replace CDISABLE with _POSIX_VDISABLE. + - use O_RDONLY and O_RDWR instead of magic `0' and `2'. + - define (and maybe use!) STDERR_FILENO and friends. + - add support for macros defined in C + - `when', `unless', `not' and `defalias' now defined in C, + so that they are universally available. + - rename defvar_mumble to defvar_magic + - rename RETURN__ to RETURN_SANS_WARNINGS + - use consistent style of initial caps in error messages + - implement last, butlast, nbutlast, copy-list in C. + - provide typedefs for all struct Lisp_foo types + - Lisp_Objects must be initialized to Qnil rather than 0. + - make sure XEmacs runs (slowly) with always_gc == 1; + - fast and safe LOOP_* macros + - change calls to XSETOBJ to XSETFOO + - replace calls to XSETINT by make_int() + - plug up memory leaks + - use style markobj (foo), not silly ((markobj) (foo)) + - use XFLOAT_DATA (obj) instead of float_data (XFLOAT (obj)) + +1998-12-02 P. E. Jareth Hein + + * unexec.c: Changed a #ifndef statement to fix XEmacs on BSDI 3.0 + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff --git a/src/EmacsFrame.c b/src/EmacsFrame.c index 40de602..2051ae4 100644 --- a/src/EmacsFrame.c +++ b/src/EmacsFrame.c @@ -40,7 +40,6 @@ Boston, MA 02111-1307, USA. */ #include "faces.h" #include "frame.h" #include "toolbar.h" -#include "redisplay.h" #include "window.h" static void EmacsFrameClassInitialize (void); @@ -115,9 +114,9 @@ static XtResource resources[] = { sizeof (int), offset (right_toolbar_border_width), XtRImmediate, (XtPointer)-1}, {XtNtopToolBarShadowColor, XtCTopToolBarShadowColor, XtRPixel, sizeof(Pixel), - offset(top_toolbar_shadow_pixel), XtRString, "#000000"}, + offset(top_toolbar_shadow_pixel), XtRString, (XtPointer) "#000000"}, {XtNbottomToolBarShadowColor, XtCBottomToolBarShadowColor, XtRPixel, - sizeof(Pixel), offset(bottom_toolbar_shadow_pixel), XtRString, "#000000"}, + sizeof(Pixel), offset(bottom_toolbar_shadow_pixel), XtRString, (XtPointer) "#000000"}, {XtNbackgroundToolBarColor, XtCBackgroundToolBarColor, XtRPixel, sizeof(Pixel), offset(background_toolbar_pixel), XtRImmediate, (XtPointer)-1}, @@ -145,11 +144,11 @@ static XtResource resources[] = { offset(font), XtRImmediate, (XtPointer)0 }, {XtNforeground, XtCForeground, XtRPixel, sizeof(Pixel), - offset(foreground_pixel), XtRString, "Black"}, + offset(foreground_pixel), XtRString, (XtPointer) "Black"}, {XtNbackground, XtCBackground, XtRPixel, sizeof(Pixel), - offset(background_pixel), XtRString, "Gray80"}, + offset(background_pixel), XtRString, (XtPointer) "Gray80"}, {XtNcursorColor, XtCForeground, XtRPixel, sizeof(Pixel), - offset(cursor_color), XtRString, "XtDefaultForeground"}, + offset(cursor_color), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNbarCursor, XtCBarCursor, XtRBoolean, sizeof (Boolean), offset (bar_cursor), XtRImmediate, (XtPointer)0}, {XtNvisualBell, XtCVisualBell, XtRBoolean, sizeof (Boolean), @@ -411,7 +410,7 @@ EmacsFrameSetValues (Widget cur_widget, Widget req_widget, Widget new_widget, f->internal_border_width = new->emacs_frame.internal_border_width; MARK_FRAME_SIZE_SLIPPED (f); } - + #ifdef HAVE_SCROLLBARS if (cur->emacs_frame.scrollbar_width != new->emacs_frame.scrollbar_width) @@ -625,7 +624,6 @@ EmacsFrameSetCharSize (Widget widget, int columns, int rows) EmacsFrame ew = (EmacsFrame) widget; int pixel_width, pixel_height; struct frame *f = ew->emacs_frame.frame; - Arg al [2]; if (columns < 3) columns = 3; /* no way buddy */ @@ -637,7 +635,10 @@ EmacsFrameSetCharSize (Widget widget, int columns, int rows) if (FRAME_X_TOP_LEVEL_FRAME_P (f)) x_wm_set_variable_size (FRAME_X_SHELL_WIDGET (f), columns, rows); - XtSetArg (al [0], XtNwidth, (Dimension) pixel_width); - XtSetArg (al [1], XtNheight, (Dimension) pixel_height); - XtSetValues ((Widget) ew, al, 2); + { + Arg al [2]; + XtSetArg (al [0], XtNwidth, pixel_width); + XtSetArg (al [1], XtNheight, pixel_height); + XtSetValues ((Widget) ew, al, countof (al)); + } } diff --git a/src/EmacsShell.c b/src/EmacsShell.c index 279c241..eef2edb 100644 --- a/src/EmacsShell.c +++ b/src/EmacsShell.c @@ -24,14 +24,12 @@ Boston, MA 02111-1307, USA. */ #include -#include +#include #include #include #include "xintrinsicp.h" #include #include -#include -#include #include "EmacsShell.h" #include "ExternalShell.h" @@ -140,17 +138,14 @@ EmacsShellSetPositionUserSpecified (Widget gw) void EmacsShellSmashIconicHint (Widget shell, int iconic_p) { - /* See comment in xfns.c about this */ - WMShellWidget wmshell; - int old, new; - if (! XtIsSubclass (shell, wmShellWidgetClass)) abort (); - wmshell = (WMShellWidget) shell; - old = (wmshell->wm.wm_hints.flags & StateHint - ? wmshell->wm.wm_hints.initial_state - : NormalState); - new = (iconic_p ? IconicState : NormalState); + /* See comment in frame-x.c about this */ + WMShellWidget wmshell = (WMShellWidget) shell; + assert (XtIsSubclass (shell, wmShellWidgetClass)); + /* old_state = (wmshell->wm.wm_hints.flags & StateHint + ? wmshell->wm.wm_hints.initial_state + : NormalState); */ wmshell->wm.wm_hints.flags |= StateHint; - wmshell->wm.wm_hints.initial_state = new; + wmshell->wm.wm_hints.initial_state = iconic_p ? IconicState : NormalState; } void diff --git a/src/Makefile.in.in b/src/Makefile.in.in index 3da462f..c8d7c2d 100644 --- a/src/Makefile.in.in +++ b/src/Makefile.in.in @@ -31,7 +31,13 @@ all: ${PROGNAME} .SUFFIXES: .SUFFIXES: .c .h .o .i .s .dep +#ifdef USE_GNU_MAKE +RECURSIVE_MAKE=$(MAKE) +#else @SET_MAKE@ +RECURSIVE_MAKE=@RECURSIVE_MAKE@ +#endif + SHELL=/bin/sh RM = rm -f @@ -44,12 +50,11 @@ prefix=@prefix@ srcdir=@srcdir@ blddir=@blddir@ version=@version@ -CC=@CC@ +CC=@XEMACS_CC@ CPP=@CPP@ CFLAGS=@CFLAGS@ CPPFLAGS=@CPPFLAGS@ LDFLAGS=@LDFLAGS@ -RECURSIVE_MAKE=@RECURSIVE_MAKE@ c_switch_all=@c_switch_all@ ld_switch_all=@ld_switch_all@ @@ -173,7 +178,7 @@ objs=\ $(gui_objs) hash.o imgproc.o indent.o insdel.o intl.o\ keymap.o $(RTC_patch_objs) line-number.o lread.o lstream.o\ macros.o marker.o md5.o minibuf.o objects.o opaque.o\ - print.o process.o profile.o pure.o\ + print.o process.o profile.o\ rangetab.o redisplay.o redisplay-output.o regex.o\ search.o $(sheap_obj) signal.o sound.o\ specifier.o strftime.o symbols.o syntax.o sysdep.o\ @@ -292,11 +297,11 @@ X11_objs = EmacsFrame.o EmacsShell.o TopLevelEmacsShell.o TransientEmacsShell.o ## define otherobjs as list of object files that make-docfile ## should not be told about. -otherobjs = $(BTL_objs) lastfile.o $(mallocobjs) $(rallocobjs) $(X11_objs) +otherobjs = lastfile.o $(mallocobjs) $(rallocobjs) $(X11_objs) otherrtls = $(otherobjs:.o=.c.rtl) othersrcs = $(otherobjs:.o=.c) -LIBES = $(lwlib_libs) $(quantify_libs) $(malloclib) $(ld_libs_all) $(lib_gcc) +LIBES = $(lwlib_libs) $(malloclib) $(ld_libs_all) $(lib_gcc) #ifdef I18N3 mo_dir = ${etcdir} @@ -305,6 +310,9 @@ mo_file = ${mo_dir}emacs.mo LOADPATH = EMACSBOOTSTRAPLOADPATH="${lispdir}:${blddir}" DUMPENV = $(LOADPATH) +temacs_loadup = $(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el +dump_temacs = ${temacs_loadup} dump +run_temacs = ${temacs_loadup} run-temacs release: temacs ${libsrc}DOC $(mo_file) ${other_files} #ifdef CANNOT_DUMP @@ -332,8 +340,8 @@ release: temacs ${libsrc}DOC $(mo_file) ${other_files} ${PROGNAME}: temacs ${libsrc}DOC $(mo_file) ${other_files} update-elc.stamp @$(RM) $@ && touch SATISFIED - -$(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el dump - @if test -f $@; then if test -f SATISFIED; then \ + -${dump_temacs} + @if test -f $@; then if test -f SATISFIED; then \ echo "Testing for Lisp shadows ..."; \ ./${PROGNAME} -batch -vanilla -f list-load-path-shadows; fi; \ $(RM) SATISFIED; exit 0; fi; \ @@ -342,8 +350,8 @@ ${PROGNAME}: temacs ${libsrc}DOC $(mo_file) ${other_files} update-elc.stamp fastdump: temacs @$(RM) ${PROGNAME} && touch SATISFIED - -$(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el dump - @if test -f ${PROGNAME}; then if test -f SATISFIED; then \ + -${dumpp_temacs} + @if test -f ${PROGNAME}; then if test -f SATISFIED; then \ ./${PROGNAME} -batch -vanilla -f list-load-path-shadows; fi; \ $(RM) SATISFIED; exit 0; fi; \ if test -f SATISFIED; then $(RM) SATISFIED; exit 1; fi; @@ -441,22 +449,31 @@ temacs: $(temacs_deps) .PHONY : run-temacs run-temacs: temacs - -$(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el run-temacs + -${run_temacs} + +## We have automated tests!! +testdir = ${srcdir}/../tests/automated +tests = \ + ${testdir}/hash-table-tests.el \ + ${testdir}/lisp-tests.el \ + ${testdir}/database-tests.el \ + ${testdir}/byte-compiler-tests.el +batch_test_emacs = -batch -l ${testdir}/test-harness.el -f batch-test-emacs ${tests} + +.PHONY: check check-temacs +check: + ./${PROGNAME} ${batch_test_emacs} +check-temacs: + ${run_temacs} ${batch_test_emacs} ## Debugging targets: ## -## RTC is Sun WorkShop's Run Time Checking -## -## Purify, Quantify, PureCoverage are software quality products from -## Rational, formerly Pure Atria, formerly Pure Software. -## -## None of these products work with a dumped xemacs binary, because it -## does unexpected things like free memory that has been malloc'ed in -## a *different* process!! So we need to run these on temacs. -## - -.PHONY : run-rtcmacs run-puremacs run-quantmacs +## None of the debugging products work with a dumped xemacs binary, +## because it does unexpected things like free memory that has been +## malloc'ed in a *different* process!! So we need to run these on +## temacs. +## RTC is Sun WorkShop's Run Time Checking, integrated with dbx rtc_patch.o: rtc_patch_area -o $@ @@ -464,6 +481,7 @@ rtcmacs: $(temacs_deps) rtc_patch.o $(RM) temacs; $(RECURSIVE_MAKE) temacs RTC_patch_objs=rtc_patch.o mv temacs rtcmacs +.PHONY: run-rtcmacs run-rtcmacs: rtcmacs dbx -q -C -c \ 'dbxenv rtc_error_log_file_name /dev/fd/1; \ @@ -474,27 +492,32 @@ run-rtcmacs: rtcmacs runargs -batch -l ${srcdir}/../lisp/loadup.el run-temacs -q; \ run' rtcmacs +## Purify, Quantify, PureCoverage are software quality products from +## Rational, formerly Pure Atria, formerly Pure Software. +## ## Purify -PURIFY_PROG=purify -PURIFY_FLAGS=-chain-length=32 -ignore-signals=SIGPOLL -threads=yes \ +PURIFY_PROG = purify +PURIFY_FLAGS = -chain-length=32 -ignore-signals=SIGPOLL -threads=yes \ -cache-dir=./purecache -always-use-cache-dir=yes -pointer-mask=0x0fffffff +PURIFY_LIBS = -lpthread puremacs: $(temacs_deps) - $(PURIFY_PROG) $(PURIFY_FLAGS) $(LD) $(temacs_link_args) -lpthread - -run-puremacs: puremacs - -$(DUMPENV) ./puremacs -batch -l ${srcdir}/../lisp/loadup.el run-temacs + $(PURIFY_PROG) $(PURIFY_FLAGS) $(LD) $(temacs_link_args) $(PURIFY_LIBS) + cp $@ temacs ## Quantify #ifdef QUANTIFY -quantify_prog = quantify -quantify_flags = -windows=no -record-data=no -quantify_includes = -I/local/include -quantify_libs = /local/lib/quantify_stubs.a +QUANTIFY_PROG = quantify +QUANTIFY_HOME = `$(QUANTIFY_PROG) -print-home-dir` +QUANTIFY_FLAGS = -cache-dir=./purecache -always-use-cache-dir=yes +cppflags += -I$(QUANTIFY_HOME) +temacs_link_args += $(QUANTIFY_HOME)/quantify_stubs.a quantmacs: $(temacs_deps) - $(quantify_prog) $(quantify_flags) $(LD) $(temacs_link_args) + $(QUANTIFY_PROG) $(QUANTIFY_FLAGS) $(LD) $(temacs_link_args) + cp $@ temacs #endif /* QUANTIFY */ + PURECOV_PROG=purecov covmacs: $(temacs_deps) $(PURECOV_PROG) $(LD) $(temacs_link_args) @@ -648,16 +671,6 @@ alloca.o : ${srcdir}/alloca.s config.h #endif /* HAVE_ALLOCA */ #endif /* ! defined (C_ALLOCA) */ -#ifdef EMACS_BTL -BTL_includes = -I$(BTL_dir) -BTL_compile = -DEMACS_BTL -D`lucid-arch` -I. $(BTL_includes) $(BTL_dir)/$(@:.o=.c) - -cadillac-btl.o cadillac-btl-process.o cadillac-btl-emacs.o: - $(CC) $(CFLAGS) -c $(BTL_compile) -cadillac-btl-asm.o: - $(CC) $(CFLAGS) -c $(BTL_compile) -#endif /* EMACS_BTL */ - #ifdef HAVE_NATIVE_SOUND sunplay.o: ${srcdir}/sunplay.c $(CC) -c $(sound_cflags) $(cflags) ${srcdir}/sunplay.c @@ -679,7 +692,7 @@ clean: mostlyclean versionclean ## Do not use it on development directories! distclean: clean $(RM) config.h paths.h Emacs.ad.h \ - Makefile Makefile.in TAGS ${PROGNAME}.* + Makefile Makefile.in GNUmakefile TAGS ${PROGNAME}.* realclean: distclean versionclean: $(RM) ${PROGNAME} ${PROGNAME}.exe ${libsrc}DOC @@ -696,7 +709,9 @@ relock: chmod -w $(SOURCES) ## Dependency processing using home-grown script, not makedepend +.PHONY: depend +FRC.depend: depend: FRC.depend - $(RM) ${srcdir}/depend depend.tmp - perl ${srcdir}/make-src-depend > depend.tmp - mv depend.tmp ${srcdir}/depend + cd ${srcdir} && $(RM) depend.tmp && \ + perl make-src-depend > depend.tmp && \ + $(RM) depend && mv depend.tmp depend diff --git a/src/abbrev.c b/src/abbrev.c index e18efdd..2add8a9 100644 --- a/src/abbrev.c +++ b/src/abbrev.c @@ -172,7 +172,7 @@ abbrev_match (struct buffer *buf, Lisp_Object obarray) It is an order of magnitude faster than the proper abbrev_match(), but then again, vi is an order of magnitude faster than Emacs. - This speed difference should be unnoticable, though. I have tested + This speed difference should be unnoticeable, though. I have tested the degenerated cases of thousands of abbrevs being defined, and abbrev_match() was still fast enough for normal operation. */ static struct Lisp_Symbol * diff --git a/src/alloc.c b/src/alloc.c index e98a472..49693df 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -51,6 +51,7 @@ Boston, MA 02111-1307, USA. */ #include "extents.h" #include "frame.h" #include "glyphs.h" +#include "opaque.h" #include "redisplay.h" #include "specifier.h" #include "sysfile.h" @@ -74,11 +75,9 @@ EXFUN (Fgarbage_collect, 0); /* Define this to see where all that space is going... */ /* But the length of the printout is obnoxious, so limit it to testers */ -/* If somebody wants to see this they can ask for it. -#ifdef DEBUG_XEMACS +#ifdef MEMORY_USAGE_STATS #define PURESTAT #endif -*/ /* Define this to use malloc/free with no freelist for all datatypes, the hope being that some debugging tools may help detect @@ -91,24 +90,13 @@ EXFUN (Fgarbage_collect, 0); #include "puresize.h" #ifdef DEBUG_XEMACS -int debug_allocation; - -int debug_allocation_backtrace_length; +static int debug_allocation; +static int debug_allocation_backtrace_length; #endif /* Number of bytes of consing done since the last gc */ EMACS_INT consing_since_gc; -#ifdef EMACS_BTL -extern void cadillac_record_backtrace (); -#define INCREMENT_CONS_COUNTER_1(size) \ - do { \ - EMACS_INT __sz__ = ((EMACS_INT) (size)); \ - consing_since_gc += __sz__; \ - cadillac_record_backtrace (2, __sz__); \ - } while (0) -#else #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size)) -#endif /* EMACS_BTL */ #define debug_allocation_backtrace() \ do { \ @@ -141,14 +129,11 @@ do { \ INCREMENT_CONS_COUNTER_1 (size) #endif -#define DECREMENT_CONS_COUNTER(size) \ - do { \ - EMACS_INT __sz__ = ((EMACS_INT) (size)); \ - if (consing_since_gc >= __sz__) \ - consing_since_gc -= __sz__; \ - else \ - consing_since_gc = 0; \ - } while (0) +#define DECREMENT_CONS_COUNTER(size) do { \ + consing_since_gc -= (size); \ + if (consing_since_gc < 0) \ + consing_since_gc = 0; \ +} while (0) /* Number of bytes of consing since gc before another gc should be done. */ EMACS_INT gc_cons_threshold; @@ -195,6 +180,9 @@ int purify_flag; extern void sheap_adjust_h(); #endif +/* Force linker to put it into data space! */ +EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0}; + #define PUREBEG ((char *) pure) #if 0 /* This is breathing_space in XEmacs */ @@ -213,7 +201,8 @@ static size_t pure_bytes_used; ((char *) (ptr) >= PUREBEG && \ (char *) (ptr) < PUREBEG + get_PURESIZE()) -/* Non-zero if pure_bytes_used > get_PURESIZE(); accounts for excess purespace needs. */ +/* Non-zero if pure_bytes_used > get_PURESIZE(); + accounts for excess purespace needs. */ static size_t pure_lossage; #ifdef ERROR_CHECK_TYPECHECK @@ -262,9 +251,9 @@ check_purespace (size_t size) #else /* PURESTAT */ -static int purecopying_for_bytecode; +static int purecopying_function_constants; -static size_t pure_sizeof (Lisp_Object /*, int recurse */); +static size_t pure_sizeof (Lisp_Object); /* Keep statistics on how much of what is in purespace */ static struct purestat @@ -276,9 +265,9 @@ static struct purestat purestat_cons = {0, 0, "cons cells"}, purestat_float = {0, 0, "float objects"}, purestat_string_pname = {0, 0, "symbol-name strings"}, - purestat_bytecode = {0, 0, "compiled-function objects"}, - purestat_string_bytecodes = {0, 0, "byte-code strings"}, - purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"}, + purestat_function = {0, 0, "compiled-function objects"}, + purestat_opaque_instructions = {0, 0, "compiled-function instructions"}, + purestat_vector_constants = {0, 0, "compiled-function constants vectors"}, purestat_string_interactive = {0, 0, "interactive strings"}, #ifdef I18N3 purestat_string_domain = {0, 0, "domain strings"}, @@ -290,27 +279,6 @@ static struct purestat purestat_string_all = {0, 0, "all strings"}, purestat_vector_all = {0, 0, "all vectors"}; -static struct purestat *purestats[] = -{ - &purestat_cons, - &purestat_float, - &purestat_string_pname, - &purestat_bytecode, - &purestat_string_bytecodes, - &purestat_vector_bytecode_constants, - &purestat_string_interactive, -#ifdef I18N3 - &purestat_string_domain, -#endif - &purestat_string_documentation, - &purestat_string_other_function, - &purestat_vector_other, - &purestat_string_other, - 0, - &purestat_string_all, - &purestat_vector_all -}; - static void bump_purestat (struct purestat *purestat, size_t nbytes) { @@ -318,13 +286,25 @@ bump_purestat (struct purestat *purestat, size_t nbytes) purestat->nobjects += 1; purestat->nbytes += nbytes; } + +static void +print_purestat (struct purestat *purestat) +{ + char buf [100]; + sprintf(buf, "%s:", purestat->name); + message (" %-36s %5d %7d %2d%%", + buf, + purestat->nobjects, + purestat->nbytes, + (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5)); +} #endif /* PURESTAT */ /* Maximum amount of C stack to save when a GC happens. */ #ifndef MAX_SAVE_STACK -#define MAX_SAVE_STACK 16000 +#define MAX_SAVE_STACK 0 /* 16000 */ #endif /* Non-zero means ignore malloc warnings. Set during initialization. */ @@ -395,12 +375,19 @@ xmalloc (size_t size) return val; } +static void * +xcalloc (size_t nelem, size_t elsize) +{ + void *val = (void *) calloc (nelem, elsize); + + if (!val && (nelem != 0)) memory_full (); + return val; +} + void * xmalloc_and_zero (size_t size) { - void *val = xmalloc (size); - memset (val, 0, size); - return val; + return xcalloc (size, sizeof (char)); } #ifdef xrealloc @@ -519,17 +506,15 @@ alloc_lcrecord (size_t size, CONST struct lrecord_implementation *implementation { struct lcrecord_header *lcheader; - if (size <= 0) abort (); +#ifdef ERROR_CHECK_GC if (implementation->static_size == 0) - { - if (!implementation->size_in_bytes_method) - abort (); - } - else if (implementation->static_size != size) - abort (); + assert (implementation->size_in_bytes_method); + else + assert (implementation->static_size == size); +#endif lcheader = (struct lcrecord_header *) allocate_lisp_storage (size); - set_lheader_implementation(&(lcheader->lheader), implementation); + set_lheader_implementation (&(lcheader->lheader), implementation); lcheader->next = all_lcrecords; #if 1 /* mly prefers to see small ID numbers */ lcheader->uid = lrecord_uid_counter++; @@ -574,7 +559,7 @@ free_lcrecord (struct lcrecord_header *lcrecord) } } if (lrecord->implementation->finalizer) - ((lrecord->implementation->finalizer) (lrecord, 0)); + lrecord->implementation->finalizer (lrecord, 0); xfree (lrecord); return; } @@ -636,9 +621,9 @@ gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type) } -/**********************************************************************/ -/* Debugger support */ -/**********************************************************************/ +/************************************************************************/ +/* Debugger support */ +/************************************************************************/ /* Give gdb/dbx enough information to decode Lisp Objects. We make sure certain symbols are defined, so gdb doesn't complain about expressions in src/gdbinit. Values are randomly chosen. @@ -657,11 +642,19 @@ enum dbg_constants dbg_USE_MINIMAL_TAGBITS = 0, dbg_Lisp_Type_Int = Lisp_Type_Int, #endif /* ! USE_MIMIMAL_TAGBITS */ + +#ifdef USE_UNION_TYPE + dbg_USE_UNION_TYPE = 1, +#else + dbg_USE_UNION_TYPE = 0, +#endif + #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1, #else dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0, #endif + dbg_Lisp_Type_Char = Lisp_Type_Char, dbg_Lisp_Type_Record = Lisp_Type_Record, #ifdef LRECORD_CONS @@ -709,10 +702,19 @@ enum dbg_constants other compilers) might optimize away the entire type declaration :-( */ } dbg_dummy; +/* A few macros turned into functions for ease of debugging. + Debuggers don't know about macros! */ +int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); +int +dbg_eq (Lisp_Object obj1, Lisp_Object obj2) +{ + return EQ (obj1, obj2); +} + -/**********************************************************************/ -/* Fixed-size type macros */ -/**********************************************************************/ +/************************************************************************/ +/* Fixed-size type macros */ +/************************************************************************/ /* For fixed-size types that are commonly used, we malloc() large blocks of memory at a time and subdivide them into chunks of the correct @@ -894,45 +896,46 @@ refill_memory_reserve () / sizeof (structtype)) #endif /* ALLOC_NO_POOLS */ -#define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ - \ -struct type##_block \ -{ \ - struct type##_block *prev; \ - structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ -}; \ - \ -static struct type##_block *current_##type##_block; \ -static int current_##type##_block_index; \ - \ -static structtype *type##_free_list; \ -static structtype *type##_free_list_tail; \ - \ -static void \ -init_##type##_alloc (void) \ -{ \ - current_##type##_block = 0; \ - current_##type##_block_index = countof (current_##type##_block->block); \ - type##_free_list = 0; \ - type##_free_list_tail = 0; \ -} \ - \ -static int gc_count_num_##type##_in_use, gc_count_num_##type##_freelist - -#define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \ - do { \ - if (current_##type##_block_index \ - == countof (current_##type##_block->block)) \ +#define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ + \ +struct type##_block \ +{ \ + struct type##_block *prev; \ + structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ +}; \ + \ +static struct type##_block *current_##type##_block; \ +static int current_##type##_block_index; \ + \ +static structtype *type##_free_list; \ +static structtype *type##_free_list_tail; \ + \ +static void \ +init_##type##_alloc (void) \ +{ \ + current_##type##_block = 0; \ + current_##type##_block_index = \ + countof (current_##type##_block->block); \ + type##_free_list = 0; \ + type##_free_list_tail = 0; \ +} \ + \ +static int gc_count_num_##type##_in_use; \ +static int gc_count_num_##type##_freelist + +#define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ + if (current_##type##_block_index \ + == countof (current_##type##_block->block)) \ { \ - struct type##_block *__new__ = (struct type##_block *) \ - allocate_lisp_storage (sizeof (struct type##_block)); \ - __new__->prev = current_##type##_block; \ - current_##type##_block = __new__; \ + struct type##_block *AFTFB_new = (struct type##_block *) \ + allocate_lisp_storage (sizeof (struct type##_block)); \ + AFTFB_new->prev = current_##type##_block; \ + current_##type##_block = AFTFB_new; \ current_##type##_block_index = 0; \ } \ - (result) = \ - &(current_##type##_block->block[current_##type##_block_index++]); \ - } while (0) + (result) = \ + &(current_##type##_block->block[current_##type##_block_index++]); \ +} while (0) /* Allocate an instance of a type that is stored in blocks. TYPE is the "name" of the type, STRUCTTYPE is the corresponding @@ -1048,22 +1051,22 @@ do { if (type##_free_list_tail) \ #else /* !ERROR_CHECK_GC */ #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \ -do { * (structtype **) ((char *) ptr + sizeof (void *)) = \ +do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \ type##_free_list; \ - type##_free_list = ptr; \ + type##_free_list = (ptr); \ } while (0) #endif /* !ERROR_CHECK_GC */ /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ -#define FREE_FIXED_TYPE(type, structtype, ptr) \ -do { structtype *_weird_ = (ptr); \ - ADDITIONAL_FREE_##type (_weird_); \ - deadbeef_memory (ptr, sizeof (structtype)); \ - PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, ptr); \ - MARK_STRUCT_AS_FREE (_weird_); \ - } while (0) +#define FREE_FIXED_TYPE(type, structtype, ptr) do { \ + structtype *FFT_ptr = (ptr); \ + ADDITIONAL_FREE_##type (FFT_ptr); \ + deadbeef_memory (FFT_ptr, sizeof (structtype)); \ + PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \ + MARK_STRUCT_AS_FREE (FFT_ptr); \ +} while (0) /* Like FREE_FIXED_TYPE() but used when we are explicitly freeing a structure through free_cons(), free_marker(), etc. @@ -1083,9 +1086,9 @@ do { FREE_FIXED_TYPE (type, structtype, ptr); \ -/**********************************************************************/ -/* Cons allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Cons allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); /* conses are used and freed so often that we set this really high */ @@ -1096,10 +1099,10 @@ DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); static Lisp_Object mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - if (NILP (XCDR (obj))) + if (GC_NILP (XCDR (obj))) return XCAR (obj); - (markobj) (XCAR (obj)); + markobj (XCAR (obj)); return XCDR (obj); } @@ -1175,7 +1178,7 @@ Any number of arguments, even zero arguments, are allowed. Lisp_Object val = Qnil; Lisp_Object *argp = args + nargs; - while (nargs-- > 0) + while (argp > args) val = Fcons (*--argp, val); return val; } @@ -1255,9 +1258,9 @@ Return a new list of length LENGTH, with each element being INIT. } -/**********************************************************************/ -/* Float allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Float allocation */ +/************************************************************************/ #ifdef LISP_FLOAT_TYPE @@ -1280,42 +1283,40 @@ make_float (double float_value) #endif /* LISP_FLOAT_TYPE */ -/**********************************************************************/ -/* Vector allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Vector allocation */ +/************************************************************************/ #ifdef LRECORD_VECTOR static Lisp_Object mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct Lisp_Vector *ptr = XVECTOR (obj); + Lisp_Vector *ptr = XVECTOR (obj); int len = vector_length (ptr); int i; for (i = 0; i < len - 1; i++) - (markobj) (ptr->contents[i]); + markobj (ptr->contents[i]); return (len > 0) ? ptr->contents[len - 1] : Qnil; } static size_t size_vector (CONST void *lheader) { - /* * -1 because struct Lisp_Vector includes 1 slot */ - return sizeof (struct Lisp_Vector) + - ((((struct Lisp_Vector *) lheader)->size - 1) * sizeof (Lisp_Object)); + return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]); } static int -vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) +vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { int indice; - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) + int len = XVECTOR_LENGTH (obj1); + if (len != XVECTOR_LENGTH (obj2)) return 0; for (indice = 0; indice < len; indice++) { - if (!internal_equal (XVECTOR_DATA (o1) [indice], - XVECTOR_DATA (o2) [indice], + if (!internal_equal (XVECTOR_DATA (obj1) [indice], + XVECTOR_DATA (obj2) [indice], depth + 1)) return 0; } @@ -1331,17 +1332,15 @@ DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector, * knows how to handle vectors. */ 0, - size_vector, struct Lisp_Vector); + size_vector, Lisp_Vector); /* #### should allocate `small' vectors from a frob-block */ -static struct Lisp_Vector * +static Lisp_Vector * make_vector_internal (size_t sizei) { - size_t sizem = (sizeof (struct Lisp_Vector) - /* -1 because struct Lisp_Vector includes 1 slot */ - + (sizei - 1) * sizeof (Lisp_Object)); - struct Lisp_Vector *p = - (struct Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector); + /* no vector_next */ + size_t sizem = offsetof (Lisp_Vector, contents[sizei]); + Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector); p->size = sizei; return p; @@ -1352,14 +1351,12 @@ make_vector_internal (size_t sizei) static Lisp_Object all_vectors; /* #### should allocate `small' vectors from a frob-block */ -static struct Lisp_Vector * +static Lisp_Vector * make_vector_internal (size_t sizei) { - size_t sizem = (sizeof (struct Lisp_Vector) - /* -1 because struct Lisp_Vector includes 1 slot, - * +1 to account for vector_next */ - + (sizei - 1 + 1) * sizeof (Lisp_Object)); - struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem); + /* + 1 to account for vector_next */ + size_t sizem = offsetof (Lisp_Vector, contents[sizei+1]); + Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem); INCREMENT_CONS_COUNTER (sizem, "vector"); @@ -1376,7 +1373,7 @@ make_vector (EMACS_INT length, Lisp_Object init) { int elt; Lisp_Object vector; - struct Lisp_Vector *p; + Lisp_Vector *p; if (length < 0) length = XINT (wrong_type_argument (Qnatnump, make_int (length))); @@ -1422,7 +1419,7 @@ Any number of arguments, even zero arguments, are allowed. { Lisp_Object vector; int elt; - struct Lisp_Vector *p = make_vector_internal (nargs); + Lisp_Vector *p = make_vector_internal (nargs); for (elt = 0; elt < nargs; elt++) vector_data(p)[elt] = args[elt]; @@ -1531,9 +1528,9 @@ vector8 (Lisp_Object obj0, Lisp_Object obj1, Lisp_Object obj2, } #endif /* unused */ -/**********************************************************************/ -/* Bit Vector allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Bit Vector allocation */ +/************************************************************************/ static Lisp_Object all_bit_vectors; @@ -1541,17 +1538,15 @@ static Lisp_Object all_bit_vectors; static struct Lisp_Bit_Vector * make_bit_vector_internal (size_t sizei) { - size_t sizem = sizeof (struct Lisp_Bit_Vector) + - /* -1 because struct Lisp_Bit_Vector includes 1 slot */ - sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1); - struct Lisp_Bit_Vector *p = - (struct Lisp_Bit_Vector *) allocate_lisp_storage (sizem); + size_t sizem = + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (sizei)]); + Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem); set_lheader_implementation (&(p->lheader), lrecord_bit_vector); INCREMENT_CONS_COUNTER (sizem, "bit-vector"); bit_vector_length (p) = sizei; - bit_vector_next (p) = all_bit_vectors; + bit_vector_next (p) = all_bit_vectors; /* make sure the extra bits in the last long are 0; the calling functions might not set them. */ p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0; @@ -1640,76 +1635,78 @@ Any number of arguments, even zero arguments, are allowed. } -/**********************************************************************/ -/* Compiled-function allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Compiled-function allocation */ +/************************************************************************/ -DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function); +DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 static Lisp_Object make_compiled_function (int make_pure) { - struct Lisp_Compiled_Function *b; - Lisp_Object new; - size_t size = sizeof (struct Lisp_Compiled_Function); + Lisp_Compiled_Function *f; + Lisp_Object fun; + size_t size = sizeof (Lisp_Compiled_Function); if (make_pure && check_purespace (size)) { - b = (struct Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used); - set_lheader_implementation (&(b->lheader), lrecord_compiled_function); + f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used); + set_lheader_implementation (&(f->lheader), lrecord_compiled_function); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION - b->lheader.pure = 1; + f->lheader.pure = 1; #endif pure_bytes_used += size; - bump_purestat (&purestat_bytecode, size); + bump_purestat (&purestat_function, size); } else { - ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function, - b); - set_lheader_implementation (&(b->lheader), lrecord_compiled_function); + ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f); + set_lheader_implementation (&(f->lheader), lrecord_compiled_function); } - b->maxdepth = 0; - b->flags.documentationp = 0; - b->flags.interactivep = 0; - b->flags.domainp = 0; /* I18N3 */ - b->bytecodes = Qzero; - b->constants = Qzero; - b->arglist = Qnil; - b->doc_and_interactive = Qnil; + f->stack_depth = 0; + f->specpdl_depth = 0; + f->flags.documentationp = 0; + f->flags.interactivep = 0; + f->flags.domainp = 0; /* I18N3 */ + f->instructions = Qzero; + f->constants = Qzero; + f->arglist = Qnil; + f->doc_and_interactive = Qnil; #ifdef COMPILED_FUNCTION_ANNOTATION_HACK - b->annotated = Qnil; + f->annotated = Qnil; #endif - XSETCOMPILED_FUNCTION (new, b); - return new; + XSETCOMPILED_FUNCTION (fun, f); + return fun; } DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* Return a new compiled-function object. -Usage: (arglist instructions constants stack-size - &optional doc-string interactive-spec) +Usage: (arglist instructions constants stack-depth + &optional doc-string interactive) Note that, unlike all other emacs-lisp functions, calling this with five arguments is NOT the same as calling it with six arguments, the last of which is nil. If the INTERACTIVE arg is specified as nil, then that means that this function was defined with `(interactive)'. If the arg is not specified, then that means the function is not interactive. This is terrible behavior which is retained for compatibility with old -`.elc' files which expected these semantics. +`.elc' files which expect these semantics. */ (int nargs, Lisp_Object *args)) { -/* In a non-insane world this function would have this arglist... - (arglist, instructions, constants, stack_size, doc_string, interactive) - Lisp_Object arglist, instructions, constants, stack_size, doc_string, - interactive; +/* In a non-insane world this function would have this arglist... + (arglist instructions constants stack_depth &optional doc_string interactive) */ + Lisp_Object fun = make_compiled_function (purify_flag); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + Lisp_Object arglist = args[0]; Lisp_Object instructions = args[1]; Lisp_Object constants = args[2]; - Lisp_Object stack_size = args[3]; + Lisp_Object stack_depth = args[3]; Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; + /* Don't purecopy the doc references in instructions because it's wasteful; they will get fixed up later. @@ -1720,143 +1717,140 @@ This is terrible behavior which is retained for compatibility with old Note: there will be a window after the byte code is created and before the doc references are fixed up in which there will be impure objects inside a pure object, which apparently won't - get marked, leading the trouble. But during that entire window, + get marked, leading to trouble. But during that entire window, the objects are sitting on Vload_force_doc_string_list, which is staticpro'd, so we're OK. */ - int purecopy_instructions = 1; + Lisp_Object (*cons) (Lisp_Object, Lisp_Object) + = purify_flag ? pure_cons : Fcons; - if (nargs > 6) + if (nargs < 4 || nargs > 6) return Fsignal (Qwrong_number_of_arguments, list2 (intern ("make-byte-code"), make_int (nargs))); - CHECK_LIST (arglist); - /* instructions is a string or a cons (string . int) for a + /* Check for valid formal parameter list now, to allow us to use + SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */ + { + Lisp_Object symbol, tail; + EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail) + { + CHECK_SYMBOL (symbol); + if (EQ (symbol, Qt) || + EQ (symbol, Qnil) || + SYMBOL_IS_KEYWORD (symbol)) + signal_simple_error_2 + ("Invalid constant symbol in formal parameter list", + symbol, arglist); + } + } + f->arglist = arglist; + + /* `instructions' is a string or a cons (string . int) for a lazy-loaded function. */ if (CONSP (instructions)) { CHECK_STRING (XCAR (instructions)); CHECK_INT (XCDR (instructions)); - if (!NILP (constants)) - CHECK_VECTOR (constants); - purecopy_instructions = 0; } else { CHECK_STRING (instructions); - CHECK_VECTOR (constants); } - CHECK_NATNUM (stack_size); - /* doc_string may be nil, string, int, or a cons (string . int). */ + f->instructions = instructions; - /* interactive may be list or string (or unbound). */ + if (!NILP (constants)) + CHECK_VECTOR (constants); + f->constants = constants; - if (purify_flag) + CHECK_NATNUM (stack_depth); + f->stack_depth = XINT (stack_depth); + +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + if (!NILP (Vcurrent_compiled_function_annotation)) + f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation); + else if (!NILP (Vload_file_name_internal_the_purecopy)) + f->annotated = Vload_file_name_internal_the_purecopy; + else if (!NILP (Vload_file_name_internal)) { - if (!purified (arglist)) - arglist = Fpurecopy (arglist); - if (purecopy_instructions && !purified (instructions)) - instructions = Fpurecopy (instructions); - if (!purified (doc_string)) - doc_string = Fpurecopy (doc_string); - if (!purified (interactive) && !UNBOUNDP (interactive)) - interactive = Fpurecopy (interactive); + struct gcpro gcpro1; + GCPRO1 (fun); /* don't let fun get reaped */ + Vload_file_name_internal_the_purecopy = + Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal)); + f->annotated = Vload_file_name_internal_the_purecopy; + UNGCPRO; + } +#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ - /* Statistics are kept differently for the constants */ - if (!purified (constants)) -#ifdef PURESTAT + /* doc_string may be nil, string, int, or a cons (string . int). + interactive may be list or string (or unbound). */ + f->doc_and_interactive = Qunbound; +#ifdef I18N3 + if ((f->flags.domainp = !NILP (Vfile_domain)) != 0) + f->doc_and_interactive = Vfile_domain; +#endif + if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0) + { + if (purify_flag) { - int old = purecopying_for_bytecode; - purecopying_for_bytecode = 1; - constants = Fpurecopy (constants); - purecopying_for_bytecode = old; + interactive = Fpurecopy (interactive); + if (STRINGP (interactive)) + bump_purestat (&purestat_string_interactive, + pure_sizeof (interactive)); } -#else - constants = Fpurecopy (constants); -#endif /* PURESTAT */ + f->doc_and_interactive + = (UNBOUNDP (f->doc_and_interactive) ? interactive : + cons (interactive, f->doc_and_interactive)); + } + if ((f->flags.documentationp = !NILP (doc_string)) != 0) + { + if (purify_flag) + { + doc_string = Fpurecopy (doc_string); + if (STRINGP (doc_string)) + /* These should have been snagged by make-docfile... */ + bump_purestat (&purestat_string_documentation, + pure_sizeof (doc_string)); + } + f->doc_and_interactive + = (UNBOUNDP (f->doc_and_interactive) ? doc_string : + cons (doc_string, f->doc_and_interactive)); + } + if (UNBOUNDP (f->doc_and_interactive)) + f->doc_and_interactive = Qnil; + + if (purify_flag) + { + + if (!purified (f->arglist)) + f->arglist = Fpurecopy (f->arglist); + /* Statistics are kept differently for the constants */ + if (!purified (f->constants)) + { #ifdef PURESTAT - if (STRINGP (instructions)) - bump_purestat (&purestat_string_bytecodes, pure_sizeof (instructions)); - if (VECTORP (constants)) - bump_purestat (&purestat_vector_bytecode_constants, - pure_sizeof (constants)); - if (STRINGP (doc_string)) - /* These should be have been snagged by make-docfile... */ - bump_purestat (&purestat_string_documentation, - pure_sizeof (doc_string)); - if (STRINGP (interactive)) - bump_purestat (&purestat_string_interactive, - pure_sizeof (interactive)); + int old = purecopying_function_constants; + purecopying_function_constants = 1; + f->constants = Fpurecopy (f->constants); + bump_purestat (&purestat_vector_constants, + pure_sizeof (f->constants)); + purecopying_function_constants = old; +#else + f->constants = Fpurecopy (f->constants); #endif /* PURESTAT */ - } + } - { - int docp = !NILP (doc_string); - int intp = !UNBOUNDP (interactive); -#ifdef I18N3 - int domp = !NILP (Vfile_domain); -#endif - Lisp_Object val = make_compiled_function (purify_flag); - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (val); - b->flags.documentationp = docp; - b->flags.interactivep = intp; -#ifdef I18N3 - b->flags.domainp = domp; -#endif - b->maxdepth = XINT (stack_size); - b->bytecodes = instructions; - b->constants = constants; - b->arglist = arglist; -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - if (!NILP (Vcurrent_compiled_function_annotation)) - b->annotated = Fpurecopy (Vcurrent_compiled_function_annotation); - else if (!NILP (Vload_file_name_internal_the_purecopy)) - b->annotated = Vload_file_name_internal_the_purecopy; - else if (!NILP (Vload_file_name_internal)) - { - struct gcpro gcpro1; - GCPRO1(val); /* don't let val or b get reaped */ - Vload_file_name_internal_the_purecopy = - Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal)); - b->annotated = Vload_file_name_internal_the_purecopy; - UNGCPRO; - } -#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ + optimize_compiled_function (fun); -#ifdef I18N3 - if (docp && intp && domp) - b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons) - (doc_string, - (((purify_flag) ? pure_cons : Fcons) - (interactive, Vfile_domain)))); - else if (docp && domp) - b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons) - (doc_string, Vfile_domain)); - else if (intp && domp) - b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons) - (interactive, Vfile_domain)); - else -#endif - if (docp && intp) - b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons) - (doc_string, interactive)); - else if (intp) - b->doc_and_interactive = interactive; -#ifdef I18N3 - else if (domp) - b->doc_and_interactive = Vfile_domain; -#endif - else - b->doc_and_interactive = doc_string; + bump_purestat (&purestat_opaque_instructions, + pure_sizeof (f->instructions)); + } - return val; - } + return fun; } -/**********************************************************************/ -/* Symbol allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Symbol allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 @@ -1865,31 +1859,31 @@ DEFUN ("make-symbol", Fmake_symbol, 1, 1, 0, /* Return a newly allocated uninterned symbol whose name is NAME. Its value and function definition are void, and its property list is nil. */ - (str)) + (name)) { Lisp_Object val; struct Lisp_Symbol *p; - CHECK_STRING (str); + CHECK_STRING (name); ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p); #ifdef LRECORD_SYMBOL set_lheader_implementation (&(p->lheader), lrecord_symbol); #endif - p->name = XSTRING (str); - p->plist = Qnil; - p->value = Qunbound; + p->name = XSTRING (name); + p->plist = Qnil; + p->value = Qunbound; p->function = Qunbound; - p->obarray = Qnil; + p->obarray = Qnil; symbol_next (p) = 0; XSETSYMBOL (val, p); return val; } -/**********************************************************************/ -/* Extent allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Extent allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 @@ -1900,7 +1894,6 @@ allocate_extent (void) struct extent *e; ALLOCATE_FIXED_TYPE (extent, struct extent, e); - /* xzero (*e); */ set_lheader_implementation (&(e->lheader), lrecord_extent); extent_object (e) = Qnil; set_extent_start (e, -1); @@ -1917,9 +1910,9 @@ allocate_extent (void) } -/**********************************************************************/ -/* Event allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Event allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 @@ -1938,9 +1931,9 @@ allocate_event (void) } -/**********************************************************************/ -/* Marker allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Marker allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 @@ -1982,9 +1975,9 @@ noseeum_make_marker (void) } -/**********************************************************************/ -/* String allocation */ -/**********************************************************************/ +/************************************************************************/ +/* String allocation */ +/************************************************************************/ /* The data for "short" strings generally resides inside of structs of type string_chars_block. The Lisp_String structure is allocated just like any @@ -2016,11 +2009,11 @@ mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object)) } static int -string_equal (Lisp_Object o1, Lisp_Object o2, int depth) +string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { Bytecount len; - return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) && - !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)); + return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && + !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); } DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, @@ -2335,30 +2328,35 @@ LENGTH must be an integer and INIT must be a character. */ (length, init)) { - Lisp_Object val; - CHECK_NATNUM (length); CHECK_CHAR_COERCE_INT (init); { - Bufbyte str[MAX_EMCHAR_LEN]; - int len = set_charptr_emchar (str, XCHAR (init)); + Bufbyte init_str[MAX_EMCHAR_LEN]; + int len = set_charptr_emchar (init_str, XCHAR (init)); + Lisp_Object val = make_uninit_string (len * XINT (length)); - val = make_uninit_string (len * XINT (length)); if (len == 1) /* Optimize the single-byte case */ memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val)); else { - int i, j, k; + int i; Bufbyte *ptr = XSTRING_DATA (val); - k = 0; - for (i = 0; i < XINT (length); i++) - for (j = 0; j < len; j++) - ptr[k++] = str[j]; + for (i = XINT (length); i; i--) + { + Bufbyte *init_ptr = init_str; + switch (len) + { + case 4: *ptr++ = *init_ptr++; + case 3: *ptr++ = *init_ptr++; + case 2: *ptr++ = *init_ptr++; + case 1: *ptr++ = *init_ptr++; + } + } } + return val; } - return val; } DEFUN ("string", Fstring, 0, MANY, 0, /* @@ -2572,23 +2570,22 @@ free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) /* Make sure the size is correct. This will catch, for example, putting a window configuration on the wrong free list. */ if (implementation->size_in_bytes_method) - assert (((implementation->size_in_bytes_method) (lheader)) - == list->size); + assert (implementation->size_in_bytes_method (lheader) == list->size); else assert (implementation->static_size == list->size); #endif /* ERROR_CHECK_GC */ if (implementation->finalizer) - ((implementation->finalizer) (lheader, 0)); + implementation->finalizer (lheader, 0); free_header->chain = list->free; free_header->lcheader.free = 1; list->free = lcrecord; } -/**********************************************************************/ -/* Purity of essence, peace on earth */ -/**********************************************************************/ +/************************************************************************/ +/* Purity of essence, peace on earth */ +/************************************************************************/ static int symbols_initialized; @@ -2641,7 +2638,7 @@ make_pure_string (CONST Bufbyte *data, Bytecount length, #ifdef PURESTAT bump_purestat (&purestat_string_all, size); - if (purecopying_for_bytecode) + if (purecopying_function_constants) bump_purestat (&purestat_string_other_function, size); #endif /* PURESTAT */ @@ -2760,16 +2757,15 @@ Lisp_Object make_pure_vector (size_t len, Lisp_Object init) { Lisp_Object new; - struct Lisp_Vector *v; - size_t size = (sizeof (struct Lisp_Vector) - + (len - 1) * sizeof (Lisp_Object)); + Lisp_Vector *v; + size_t size = offsetof (Lisp_Vector, contents[len]); init = Fpurecopy (init); if (!check_purespace (size)) return make_vector (len, init); - v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used); + v = (Lisp_Vector *) (PUREBEG + pure_bytes_used); #ifdef LRECORD_VECTOR set_lheader_implementation (&(v->header.lheader), lrecord_vector); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION @@ -2813,115 +2809,107 @@ Does not copy symbols. */ (obj)) { - int i; if (!purify_flag) - return obj; - - if (!POINTER_TYPE_P (XTYPE (obj)) - || PURIFIED (XPNTR (obj)) - /* happens when bootstrapping Qnil */ - || EQ (obj, Qnull_pointer)) - return obj; - - switch (XTYPE (obj)) { -#ifndef LRECORD_CONS - case Lisp_Type_Cons: + return obj; + } + else if (!POINTER_TYPE_P (XTYPE (obj)) + || PURIFIED (XPNTR (obj)) + /* happens when bootstrapping Qnil */ + || EQ (obj, Qnull_pointer)) + { + return obj; + } + /* Order of subsequent tests determined via profiling. */ + else if (SYMBOLP (obj)) + { + /* Symbols can't be made pure (and thus read-only), because + assigning to their function, value or plist slots would + produced a SEGV in the dumped XEmacs. So we previously would + just return the symbol unchanged. + + But purified aggregate objects like lists and vectors can + contain uninterned symbols. If there are no other non-pure + references to the symbol, then the symbol is not protected + from garbage collection because the collector does not mark + the contents of purified objects. So to protect the symbols, + an impure reference has to be kept for each uninterned symbol + that is referenced by a pure object. All such symbols are + stored in the hash table pointed to by + Vpure_uninterned_symbol_table, which is itself + staticpro'd. */ + if (NILP (XSYMBOL (obj)->obarray)) + Fputhash (obj, Qnil, Vpure_uninterned_symbol_table); + return obj; + } + else if (CONSP (obj)) + { return pure_cons (XCAR (obj), XCDR (obj)); -#endif - -#ifndef LRECORD_STRING - case Lisp_Type_String: + } + else if (STRINGP (obj)) + { return make_pure_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj), XSTRING (obj)->plist, - 0); -#endif /* ! LRECORD_STRING */ + 0); + } + else if (VECTORP (obj)) + { + int i; + Lisp_Vector *o = XVECTOR (obj); + Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil); + for (i = 0; i < vector_length (o); i++) + XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]); + return pure_obj; + } +#ifdef LISP_FLOAT_TYPE + else if (FLOATP (obj)) + { + return make_pure_float (XFLOAT_DATA (obj)); + } +#endif + else if (COMPILED_FUNCTIONP (obj)) + { + Lisp_Object pure_obj = make_compiled_function (1); + Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj); + Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj); + n->flags = o->flags; + n->instructions = o->instructions; + n->constants = Fpurecopy (o->constants); + n->arglist = Fpurecopy (o->arglist); + n->doc_and_interactive = Fpurecopy (o->doc_and_interactive); + n->stack_depth = o->stack_depth; + optimize_compiled_function (pure_obj); + return pure_obj; + } + else if (OPAQUEP (obj)) + { + Lisp_Object pure_obj; + Lisp_Opaque *old_opaque = XOPAQUE (obj); + Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used); + struct lrecord_header *lheader = XRECORD_LHEADER (obj); + CONST struct lrecord_implementation *implementation + = LHEADER_IMPLEMENTATION (lheader); + size_t size = implementation->size_in_bytes_method (lheader); + size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object)); + if (!check_purespace (pure_size)) + return obj; + pure_bytes_used += pure_size; -#ifndef LRECORD_VECTOR - case Lisp_Type_Vector: - { - struct Lisp_Vector *o = XVECTOR (obj); - Lisp_Object new = make_pure_vector (vector_length (o), Qnil); - for (i = 0; i < vector_length (o); i++) - XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]); - return new; - } -#endif /* !LRECORD_VECTOR */ + memcpy (new_opaque, old_opaque, size); +#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION + lheader->pure = 1; +#endif + new_opaque->header.next = 0; - default: - { - if (COMPILED_FUNCTIONP (obj)) - { - struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj); - Lisp_Object new = make_compiled_function (1); - /* How on earth could this code have worked before? -sb */ - struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new); - n->flags = o->flags; - n->bytecodes = Fpurecopy (o->bytecodes); - n->constants = Fpurecopy (o->constants); - n->arglist = Fpurecopy (o->arglist); - n->doc_and_interactive = Fpurecopy (o->doc_and_interactive); - n->maxdepth = o->maxdepth; - return new; - } -#ifdef LRECORD_CONS - else if (CONSP (obj)) - return pure_cons (XCAR (obj), XCDR (obj)); -#endif /* LRECORD_CONS */ -#ifdef LRECORD_VECTOR - else if (VECTORP (obj)) - { - struct Lisp_Vector *o = XVECTOR (obj); - Lisp_Object new = make_pure_vector (vector_length (o), Qnil); - for (i = 0; i < vector_length (o); i++) - XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]); - return new; - } -#endif /* LRECORD_VECTOR */ -#ifdef LRECORD_STRING - else if (STRINGP (obj)) - { - return make_pure_string (XSTRING_DATA (obj), - XSTRING_LENGTH (obj), - XSTRING (obj)->plist, - 0); - } -#endif /* LRECORD_STRING */ -#ifdef LISP_FLOAT_TYPE - else if (FLOATP (obj)) - return make_pure_float (float_data (XFLOAT (obj))); -#endif /* LISP_FLOAT_TYPE */ - else if (SYMBOLP (obj)) - { - /* - * Symbols can't be made pure (and thus read-only), - * because assigning to their function, value or plist - * slots would produced a SEGV in the dumped XEmacs. So - * we previously would just return the symbol unchanged. - * - * But purified aggregate objects like lists and vectors - * can contain uninterned symbols. If there are no - * other non-pure references to the symbol, then the - * symbol is not protected from garbage collection - * because the collector does not mark the contents of - * purified objects. So to protect the symbols, an impure - * reference has to be kept for each uninterned symbol - * that is referenced by a pure object. All such - * symbols are stored in the hashtable pointed to by - * Vpure_uninterned_symbol_table, which is itself - * staticpro'd. - */ - if (!NILP (XSYMBOL (obj)->obarray)) - return obj; - Fputhash (obj, Qnil, Vpure_uninterned_symbol_table); - return obj; - } - else - signal_simple_error ("Can't purecopy %S", obj); - } + XSETOPAQUE (pure_obj, new_opaque); + return pure_obj; } - return obj; + else + { + signal_simple_error ("Can't purecopy %S", obj); + } + return obj; /* Unreached */ } @@ -2999,15 +2987,14 @@ report_pure_usage (int report_impurities, purestat_vector_other.nbytes = purestat_vector_all.nbytes - - purestat_vector_bytecode_constants.nbytes; + purestat_vector_constants.nbytes; purestat_vector_other.nobjects = purestat_vector_all.nobjects - - purestat_vector_bytecode_constants.nobjects; + purestat_vector_constants.nobjects; purestat_string_other.nbytes = purestat_string_all.nbytes - (purestat_string_pname.nbytes + - purestat_string_bytecodes.nbytes + purestat_string_interactive.nbytes + purestat_string_documentation.nbytes + #ifdef I18N3 @@ -3018,7 +3005,6 @@ report_pure_usage (int report_impurities, purestat_string_other.nobjects = purestat_string_all.nobjects - (purestat_string_pname.nobjects + - purestat_string_bytecodes.nobjects + purestat_string_interactive.nobjects + purestat_string_documentation.nobjects + #ifdef I18N3 @@ -3026,59 +3012,53 @@ report_pure_usage (int report_impurities, #endif purestat_string_other_function.nobjects); - message (" %-26s Total Bytes", ""); + message (" %-34s Objects Bytes", ""); - { - int j; + print_purestat (&purestat_cons); + print_purestat (&purestat_float); + print_purestat (&purestat_string_pname); + print_purestat (&purestat_function); + print_purestat (&purestat_opaque_instructions); + print_purestat (&purestat_vector_constants); + print_purestat (&purestat_string_interactive); +#ifdef I18N3 + print_purestat (&purestat_string_domain); +#endif + print_purestat (&purestat_string_documentation); + print_purestat (&purestat_string_other_function); + print_purestat (&purestat_vector_other); + print_purestat (&purestat_string_other); + print_purestat (&purestat_string_all); + print_purestat (&purestat_vector_all); - for (j = 0; j < countof (purestats); j++) - if (!purestats[j]) - clear_message (); - else - { - char buf [100]; - sprintf(buf, "%s:", purestats[j]->name); - message (" %-26s %5d %7d %2d%%", - buf, - purestats[j]->nobjects, - purestats[j]->nbytes, - (int) (purestats[j]->nbytes / (pure_bytes_used / 100.0) + 0.5)); - } - } #endif /* PURESTAT */ if (report_impurities) { - Lisp_Object tem = Felt (Fgarbage_collect (), make_int (5)); + Lisp_Object plist; struct gcpro gcpro1; - GCPRO1 (tem); + plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect())))))); + GCPRO1 (plist); message ("\nImpurities:"); - while (!NILP (tem)) + for (; CONSP (plist); plist = XCDR (XCDR (plist))) { - if (CONSP (tem) && SYMBOLP (Fcar (tem)) && CONSP (Fcdr (tem))) - { - int total = XINT (Fcar (Fcdr (tem))); - if (total > 0) - { - char buf [100]; - char *s = buf; - memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name), - string_length (XSYMBOL (Fcar (tem))->name) + 1); - while (*s++) if (*s == '-') *s = ' '; - s--; *s++ = ':'; *s = 0; - message (" %-33s %6d", buf, total); - } - tem = Fcdr (Fcdr (tem)); - } - else /* WTF?! */ + Lisp_Object symbol = XCAR (plist); + int size = XINT (XCAR (XCDR (plist))); + if (size > 0) { - Fprin1 (tem, Qexternal_debugging_output); - tem = Qnil; + char buf [100]; + char *s = buf; + memcpy (buf, + string_data (XSYMBOL (symbol)->name), + string_length (XSYMBOL (symbol)->name) + 1); + while (*s++) if (*s == '-') *s = ' '; + *(s-1) = ':'; *s = 0; + message (" %-34s %6d", buf, size); } } UNGCPRO; - garbage_collect_1 (); /* GC garbage_collect's garbage */ + garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */ } clear_message (); @@ -3091,9 +3071,15 @@ report_pure_usage (int report_impurities, } -/**********************************************************************/ -/* staticpro */ -/**********************************************************************/ +/************************************************************************/ +/* Garbage Collection */ +/************************************************************************/ + +/* This will be used more extensively In The Future */ +static int last_lrecord_type_index_assigned; + +CONST struct lrecord_implementation *lrecord_implementations_table[128]; +#define max_lrecord_type (countof (lrecord_implementations_table) - 1) struct gcpro *gcprolist; @@ -3131,23 +3117,27 @@ mark_object (Lisp_Object obj) { tail_recurse: - if (EQ (obj, Qnull_pointer)) - return; - if (!POINTER_TYPE_P (XGCTYPE (obj))) - return; - if (PURIFIED (XPNTR (obj))) - return; +#ifdef ERROR_CHECK_GC + assert (! (GC_EQ (obj, Qnull_pointer))); +#endif + /* Checks we used to perform */ + /* if (EQ (obj, Qnull_pointer)) return; */ + /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ + /* if (PURIFIED (XPNTR (obj))) return; */ + switch (XGCTYPE (obj)) { #ifndef LRECORD_CONS case Lisp_Type_Cons: { struct Lisp_Cons *ptr = XCONS (obj); + if (PURIFIED (ptr)) + break; if (CONS_MARKED_P (ptr)) break; MARK_CONS (ptr); /* If the cdr is nil, tail-recurse on the car. */ - if (NILP (ptr->cdr)) + if (GC_NILP (ptr->cdr)) { obj = ptr->car; } @@ -3161,24 +3151,28 @@ mark_object (Lisp_Object obj) #endif case Lisp_Type_Record: - /* case Lisp_Symbol_Value_Magic: */ { struct lrecord_header *lheader = XRECORD_LHEADER (obj); - CONST struct lrecord_implementation *implementation - = LHEADER_IMPLEMENTATION (lheader); +#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION) + assert (lheader->type <= last_lrecord_type_index_assigned); +#endif + if (PURIFIED (lheader)) + return; if (! MARKED_RECORD_HEADER_P (lheader) && ! UNMARKABLE_RECORD_HEADER_P (lheader)) { + CONST struct lrecord_implementation *implementation = + LHEADER_IMPLEMENTATION (lheader); MARK_RECORD_HEADER (lheader); #ifdef ERROR_CHECK_GC if (!implementation->basic_p) assert (! ((struct lcrecord_header *) lheader)->free); #endif - if (implementation->marker != 0) + if (implementation->marker) { - obj = ((implementation->marker) (obj, mark_object)); - if (!NILP (obj)) goto tail_recurse; + obj = implementation->marker (obj, mark_object); + if (!GC_NILP (obj)) goto tail_recurse; } } } @@ -3188,6 +3182,8 @@ mark_object (Lisp_Object obj) case Lisp_Type_String: { struct Lisp_String *ptr = XSTRING (obj); + if (PURIFIED (ptr)) + return; if (!XMARKBIT (ptr->plist)) { @@ -3206,8 +3202,12 @@ mark_object (Lisp_Object obj) case Lisp_Type_Vector: { struct Lisp_Vector *ptr = XVECTOR (obj); - int len = vector_length (ptr); - int i; + int len, i; + + if (PURIFIED (ptr)) + return; + + len = vector_length (ptr); if (len < 0) break; /* Already marked */ @@ -3228,6 +3228,9 @@ mark_object (Lisp_Object obj) { struct Lisp_Symbol *sym = XSYMBOL (obj); + if (PURIFIED (sym)) + return; + while (!XMARKBIT (sym->plist)) { XMARK (sym->plist); @@ -3239,8 +3242,8 @@ mark_object (Lisp_Object obj) * Lisp_Object. Fix it up and pass to mark_object. */ Lisp_Object symname; - XSETSTRING(symname, sym->name); - mark_object(symname); + XSETSTRING (symname, sym->name); + mark_object (symname); } if (!symbol_next (sym)) { @@ -3255,8 +3258,15 @@ mark_object (Lisp_Object obj) break; #endif /* !LRECORD_SYMBOL */ + /* Check for invalid Lisp_Object types */ +#if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS) + case Lisp_Type_Int: + case Lisp_Type_Char: + break; default: - abort (); + abort(); + break; +#endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */ } } @@ -3286,15 +3296,6 @@ mark_conses_in_list (Lisp_Object obj) /* Simpler than mark-object, because pure structure can't have any circularities */ -#if 0 /* unused */ -static int idiot_c_doesnt_have_closures; -static void -idiot_c (Lisp_Object obj) -{ - idiot_c_doesnt_have_closures += pure_sizeof (obj, 1); -} -#endif /* unused */ - static size_t pure_string_sizeof (Lisp_Object obj) { @@ -3314,120 +3315,40 @@ pure_string_sizeof (Lisp_Object obj) } } -/* recurse arg isn't actually used */ static size_t -pure_sizeof (Lisp_Object obj /*, int recurse */) +pure_sizeof (Lisp_Object obj) { - size_t total = 0; - - /*tail_recurse: */ if (!POINTER_TYPE_P (XTYPE (obj)) || !PURIFIED (XPNTR (obj))) - return total; - - /* symbol's sizes are accounted for separately */ - if (SYMBOLP (obj)) - return total; - - switch (XTYPE (obj)) + return 0; + /* symbol sizes are accounted for separately */ + else if (SYMBOLP (obj)) + return 0; + else if (STRINGP (obj)) + return pure_string_sizeof (obj); + else if (LRECORDP (obj)) { + struct lrecord_header *lheader = XRECORD_LHEADER (obj); + CONST struct lrecord_implementation *implementation + = LHEADER_IMPLEMENTATION (lheader); -#ifndef LRECORD_STRING - case Lisp_Type_String: - total += pure_string_sizeof (obj); - break; -#endif /* ! LRECORD_STRING */ - + return implementation->size_in_bytes_method + ? implementation->size_in_bytes_method (lheader) + : implementation->static_size; + } #ifndef LRECORD_VECTOR - case Lisp_Type_Vector: - { - struct Lisp_Vector *ptr = XVECTOR (obj); - int len = vector_length (ptr); - - total += (sizeof (struct Lisp_Vector) - + (len - 1) * sizeof (Lisp_Object)); -#if 0 /* unused */ - if (!recurse) - break; - { - int i; - for (i = 0; i < len - 1; i++) - total += pure_sizeof (ptr->contents[i], 1); - } - if (len > 0) - { - obj = ptr->contents[len - 1]; - goto tail_recurse; - } -#endif /* unused */ - } - break; + else if (VECTORP (obj)) + return offsetof (Lisp_Vector, contents[XVECTOR_LENGTH (obj)]); #endif /* !LRECORD_VECTOR */ - case Lisp_Type_Record: - { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - CONST struct lrecord_implementation *implementation - = LHEADER_IMPLEMENTATION (lheader); - -#ifdef LRECORD_STRING - if (STRINGP (obj)) - total += pure_string_sizeof (obj); - else -#endif - if (implementation->size_in_bytes_method) - total += ((implementation->size_in_bytes_method) (lheader)); - else - total += implementation->static_size; - -#if 0 /* unused */ - if (!recurse) - break; - - if (implementation->marker != 0) - { - int old = idiot_c_doesnt_have_closures; - - idiot_c_doesnt_have_closures = 0; - obj = ((implementation->marker) (obj, idiot_c)); - total += idiot_c_doesnt_have_closures; - idiot_c_doesnt_have_closures = old; - - if (!NILP (obj)) goto tail_recurse; - } -#endif /* unused */ - } - break; - #ifndef LRECORD_CONS - case Lisp_Type_Cons: - { - struct Lisp_Cons *ptr = XCONS (obj); - total += sizeof (*ptr); -#if 0 /* unused */ - if (!recurse) - break; - /* If the cdr is nil, tail-recurse on the car. */ - if (NILP (ptr->cdr)) - { - obj = ptr->car; - } - else - { - total += pure_sizeof (ptr->car, 1); - obj = ptr->cdr; - } - goto tail_recurse; -#endif /* unused */ - } - break; -#endif - - /* Others can't be purified */ - default: - abort (); - } - return total; + else if (CONSP (obj)) + return sizeof (struct Lisp_Cons); +#endif /* !LRECORD_CONS */ + else + /* Others can't be purified */ + abort (); + return 0; /* unreached */ } #endif /* PURESTAT */ @@ -3449,12 +3370,6 @@ static int gc_count_short_string_total_size; /* static int gc_count_total_records_used, gc_count_records_total_size; */ -/* This will be used more extensively In The Future */ -static int last_lrecord_type_index_assigned; - -CONST struct lrecord_implementation *lrecord_implementations_table[128]; -#define max_lrecord_type (countof (lrecord_implementations_table) - 1) - int lrecord_type_index (CONST struct lrecord_implementation *implementation) { @@ -3515,7 +3430,7 @@ tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p) else { size_t sz = (implementation->size_in_bytes_method - ? ((implementation->size_in_bytes_method) (h)) + ? implementation->size_in_bytes_method (h) : implementation->static_size); if (free_p) @@ -3557,7 +3472,7 @@ sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) if (!MARKED_RECORD_HEADER_P (h) && ! (header->free)) { if (LHEADER_IMPLEMENTATION (h)->finalizer) - ((LHEADER_IMPLEMENTATION (h)->finalizer) (h, 0)); + LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); } } @@ -3568,7 +3483,7 @@ sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) { UNMARK_RECORD_HEADER (h); num_used++; - /* total_size += ((n->implementation->size_in_bytes) (h));*/ + /* total_size += n->implementation->size_in_bytes (h);*/ prev = &(header->next); header = *prev; tick_lcrecord_stats (h, 0); @@ -3600,16 +3515,15 @@ sweep_vectors_1 (Lisp_Object *prev, for (vector = *prev; VECTORP (vector); ) { - struct Lisp_Vector *v = XVECTOR (vector); + Lisp_Vector *v = XVECTOR (vector); int len = v->size; if (len < 0) /* marked */ { len = - (len + 1); v->size = len; total_size += len; - total_storage += (MALLOC_OVERHEAD - + sizeof (struct Lisp_Vector) - + (len - 1 + 1) * sizeof (Lisp_Object)); + total_storage += + MALLOC_OVERHEAD + offsetof (Lisp_Vector, contents[len + 1]); num_used++; prev = &(vector_next (v)); vector = *prev; @@ -3642,16 +3556,15 @@ sweep_bit_vectors_1 (Lisp_Object *prev, their implementation */ for (bit_vector = *prev; !EQ (bit_vector, Qzero); ) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); + Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); int len = v->size; if (MARKED_RECORD_P (bit_vector)) { UNMARK_RECORD_HEADER (&(v->lheader)); total_size += len; - total_storage += (MALLOC_OVERHEAD - + sizeof (struct Lisp_Bit_Vector) - + (BIT_VECTOR_LONG_STORAGE (len) - 1) - * sizeof (long)); + total_storage += + MALLOC_OVERHEAD + + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]); num_used++; prev = &(bit_vector_next (v)); bit_vector = *prev; @@ -3676,41 +3589,41 @@ sweep_bit_vectors_1 (Lisp_Object *prev, #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ do { \ - struct typename##_block *_frob_current; \ - struct typename##_block **_frob_prev; \ - int _frob_limit; \ + struct typename##_block *SFTB_current; \ + struct typename##_block **SFTB_prev; \ + int SFTB_limit; \ int num_free = 0, num_used = 0; \ \ - for (_frob_prev = ¤t_##typename##_block, \ - _frob_current = current_##typename##_block, \ - _frob_limit = current_##typename##_block_index; \ - _frob_current; \ + for (SFTB_prev = ¤t_##typename##_block, \ + SFTB_current = current_##typename##_block, \ + SFTB_limit = current_##typename##_block_index; \ + SFTB_current; \ ) \ { \ - int _frob_iii; \ + int SFTB_iii; \ \ - for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \ + for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ { \ - obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \ + obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ \ - if (FREE_STRUCT_P (_frob_victim)) \ + if (FREE_STRUCT_P (SFTB_victim)) \ { \ num_free++; \ } \ - else if (!MARKED_##typename##_P (_frob_victim)) \ + else if (!MARKED_##typename##_P (SFTB_victim)) \ { \ num_free++; \ - FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \ + FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ } \ else \ { \ num_used++; \ - UNMARK_##typename (_frob_victim); \ + UNMARK_##typename (SFTB_victim); \ } \ } \ - _frob_prev = &(_frob_current->prev); \ - _frob_current = _frob_current->prev; \ - _frob_limit = countof (current_##typename##_block->block); \ + SFTB_prev = &(SFTB_current->prev); \ + SFTB_current = SFTB_current->prev; \ + SFTB_limit = countof (current_##typename##_block->block); \ } \ \ gc_count_num_##typename##_in_use = num_used; \ @@ -3719,77 +3632,77 @@ do { \ #else /* !ERROR_CHECK_GC */ -#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ -do { \ - struct typename##_block *_frob_current; \ - struct typename##_block **_frob_prev; \ - int _frob_limit; \ - int num_free = 0, num_used = 0; \ - \ - typename##_free_list = 0; \ - \ - for (_frob_prev = ¤t_##typename##_block, \ - _frob_current = current_##typename##_block, \ - _frob_limit = current_##typename##_block_index; \ - _frob_current; \ - ) \ - { \ - int _frob_iii; \ - int _frob_empty = 1; \ - obj_type *_frob_old_free_list = typename##_free_list; \ - \ - for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \ - { \ - obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \ - \ - if (FREE_STRUCT_P (_frob_victim)) \ - { \ - num_free++; \ - PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, _frob_victim); \ - } \ - else if (!MARKED_##typename##_P (_frob_victim)) \ - { \ - num_free++; \ - FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \ - } \ - else \ - { \ - _frob_empty = 0; \ - num_used++; \ - UNMARK_##typename (_frob_victim); \ - } \ - } \ - if (!_frob_empty) \ - { \ - _frob_prev = &(_frob_current->prev); \ - _frob_current = _frob_current->prev; \ - } \ - else if (_frob_current == current_##typename##_block \ - && !_frob_current->prev) \ - { \ - /* No real point in freeing sole allocation block */ \ - break; \ - } \ - else \ - { \ - struct typename##_block *_frob_victim_block = _frob_current; \ - if (_frob_victim_block == current_##typename##_block) \ - current_##typename##_block_index \ - = countof (current_##typename##_block->block); \ - _frob_current = _frob_current->prev; \ - { \ - *_frob_prev = _frob_current; \ - xfree (_frob_victim_block); \ - /* Restore free list to what it was before victim was swept */ \ - typename##_free_list = _frob_old_free_list; \ - num_free -= _frob_limit; \ - } \ - } \ - _frob_limit = countof (current_##typename##_block->block); \ - } \ - \ - gc_count_num_##typename##_in_use = num_used; \ - gc_count_num_##typename##_freelist = num_free; \ +#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ +do { \ + struct typename##_block *SFTB_current; \ + struct typename##_block **SFTB_prev; \ + int SFTB_limit; \ + int num_free = 0, num_used = 0; \ + \ + typename##_free_list = 0; \ + \ + for (SFTB_prev = ¤t_##typename##_block, \ + SFTB_current = current_##typename##_block, \ + SFTB_limit = current_##typename##_block_index; \ + SFTB_current; \ + ) \ + { \ + int SFTB_iii; \ + int SFTB_empty = 1; \ + obj_type *SFTB_old_free_list = typename##_free_list; \ + \ + for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ + { \ + obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ + \ + if (FREE_STRUCT_P (SFTB_victim)) \ + { \ + num_free++; \ + PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ + } \ + else if (!MARKED_##typename##_P (SFTB_victim)) \ + { \ + num_free++; \ + FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ + } \ + else \ + { \ + SFTB_empty = 0; \ + num_used++; \ + UNMARK_##typename (SFTB_victim); \ + } \ + } \ + if (!SFTB_empty) \ + { \ + SFTB_prev = &(SFTB_current->prev); \ + SFTB_current = SFTB_current->prev; \ + } \ + else if (SFTB_current == current_##typename##_block \ + && !SFTB_current->prev) \ + { \ + /* No real point in freeing sole allocation block */ \ + break; \ + } \ + else \ + { \ + struct typename##_block *SFTB_victim_block = SFTB_current; \ + if (SFTB_victim_block == current_##typename##_block) \ + current_##typename##_block_index \ + = countof (current_##typename##_block->block); \ + SFTB_current = SFTB_current->prev; \ + { \ + *SFTB_prev = SFTB_current; \ + xfree (SFTB_victim_block); \ + /* Restore free list to what it was before victim was swept */ \ + typename##_free_list = SFTB_old_free_list; \ + num_free -= SFTB_limit; \ + } \ + } \ + SFTB_limit = countof (current_##typename##_block->block); \ + } \ + \ + gc_count_num_##typename##_in_use = num_used; \ + gc_count_num_##typename##_freelist = num_free; \ } while (0) #endif /* !ERROR_CHECK_GC */ @@ -3875,7 +3788,7 @@ sweep_compiled_functions (void) #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) #define ADDITIONAL_FREE_compiled_function(ptr) - SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function); + SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); } @@ -4193,33 +4106,65 @@ sweep_strings (void) static int marked_p (Lisp_Object obj) { - if (EQ (obj, Qnull_pointer)) return 1; - if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; - if (PURIFIED (XPNTR (obj))) return 1; +#ifdef ERROR_CHECK_GC + assert (! (GC_EQ (obj, Qnull_pointer))); +#endif + /* Checks we used to perform. */ + /* if (EQ (obj, Qnull_pointer)) return 1; */ + /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ + /* if (PURIFIED (XPNTR (obj))) return 1; */ + switch (XGCTYPE (obj)) { #ifndef LRECORD_CONS case Lisp_Type_Cons: - return XMARKBIT (XCAR (obj)); + { + struct Lisp_Cons *ptr = XCONS (obj); + return PURIFIED (ptr) || XMARKBIT (ptr->car); + } #endif case Lisp_Type_Record: - return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj)); + { + struct lrecord_header *lheader = XRECORD_LHEADER (obj); +#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION) + assert (lheader->type <= last_lrecord_type_index_assigned); +#endif + return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader); + } #ifndef LRECORD_STRING case Lisp_Type_String: - return XMARKBIT (XSTRING (obj)->plist); + { + struct Lisp_String *ptr = XSTRING (obj); + return PURIFIED (ptr) || XMARKBIT (ptr->plist); + } #endif /* ! LRECORD_STRING */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: - return XVECTOR_LENGTH (obj) < 0; + { + struct Lisp_Vector *ptr = XVECTOR (obj); + return PURIFIED (ptr) || vector_length (ptr) < 0; + } #endif /* !LRECORD_VECTOR */ #ifndef LRECORD_SYMBOL case Lisp_Type_Symbol: - return XMARKBIT (XSYMBOL (obj)->plist); + { + struct Lisp_Symbol *ptr = XSYMBOL (obj); + return PURIFIED (ptr) || XMARKBIT (ptr->plist); + } #endif + + /* Ints and Chars don't need GC */ +#if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC) default: - abort (); + return 1; +#else + default: + abort(); + case Lisp_Type_Int: + case Lisp_Type_Char: + return 1; +#endif } - return 0; /* suppress compiler warning */ } static void @@ -4297,7 +4242,7 @@ disksave_object_finalization (void) { /* It's important that certain information from the environment not get dumped with the executable (pathnames, environment variables, etc.). - To make it easier to tell when this has happend with strings(1) we + To make it easier to tell when this has happened with strings(1) we clear some known-to-be-garbage blocks of memory, so that leftover results of old evaluation don't look like potential problems. But first we set some notable variables to nil and do one more GC, @@ -4370,8 +4315,10 @@ static int gc_hooks_inhibited; void garbage_collect_1 (void) { +#if MAX_SAVE_STACK > 0 char stack_top_variable; extern char *stack_bottom; +#endif int i; struct frame *f; int speccount; @@ -4385,13 +4332,24 @@ garbage_collect_1 (void) || preparing_for_armageddon) return; + /* We used to call selected_frame() here. + + The following functions cannot be called inside GC + so we move to after the above tests. */ + { + Lisp_Object frame; + Lisp_Object device = Fselected_device (Qnil); + if (NILP (device)) /* Could happen during startup, eg. if always_gc */ + return; + frame = DEVICE_SELECTED_FRAME (XDEVICE (device)); + if (NILP (frame)) + signal_simple_error ("No frames exist on device", device); + f = XFRAME (frame); + } + pre_gc_cursor = Qnil; cursor_changed = 0; - /* This function cannot be called inside GC so we move to after the */ - /* above tests */ - f = selected_frame (); - GCPRO1 (pre_gc_cursor); /* Very important to prevent GC during any of the following @@ -4486,10 +4444,6 @@ garbage_collect_1 (void) for (i = 0; i < staticidx; i++) { -#ifdef GDB_SUCKS - printf ("%d\n", i); - debug_print (*staticvec[i]); -#endif mark_object (*(staticvec[i])); } @@ -4528,29 +4482,21 @@ garbage_collect_1 (void) } /* OK, now do the after-mark stuff. This is for things that - are only marked when something else is marked (e.g. weak hashtables). + are only marked when something else is marked (e.g. weak hash tables). There may be complex dependencies between such objects -- e.g. - a weak hashtable might be unmarked, but after processing a later - weak hashtable, the former one might get marked. So we have to + a weak hash table might be unmarked, but after processing a later + weak hash table, the former one might get marked. So we have to iterate until nothing more gets marked. */ - { - int did_mark; - /* Need to iterate until there's nothing more to mark, in case - of chains of mark dependencies. */ - do - { - did_mark = 0; - did_mark += !!finish_marking_weak_hashtables (marked_p, mark_object); - did_mark += !!finish_marking_weak_lists (marked_p, mark_object); - } - while (did_mark); - } + + while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 || + finish_marking_weak_lists (marked_p, mark_object) > 0) + ; /* And prune (this needs to be called after everything else has been marked and before we do any sweeping). */ /* #### this is somewhat ad-hoc and should probably be an object method */ - prune_weak_hashtables (marked_p); + prune_weak_hash_tables (marked_p); prune_weak_lists (marked_p); prune_specifiers (marked_p); prune_syntax_tables (marked_p); @@ -4610,15 +4556,6 @@ garbage_collect_1 (void) return; } -#ifdef EMACS_BTL - /* This isn't actually called. BTL recognizes the stack frame of the top - of the garbage collector by noting that PC is between &garbage_collect_1 - and &BTL_after_garbage_collect_1_stub. So this fn must be right here. - There's not any other way to know the address of the end of a function. - */ -void BTL_after_garbage_collect_1_stub () { abort (); } -#endif /* EMACS_BTL */ - /* Debugging aids. */ static Lisp_Object @@ -4630,13 +4567,12 @@ gc_plist_hack (CONST char *name, int value, Lisp_Object tail) return cons3 (intern (name), make_int (value), tail); } -#define HACK_O_MATIC(type, name, pl) \ - { \ - int s = 0; \ - struct type##_block *x = current_##type##_block; \ - while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ - (pl) = gc_plist_hack ((name), s, (pl)); \ - } +#define HACK_O_MATIC(type, name, pl) do { \ + int s = 0; \ + struct type##_block *x = current_##type##_block; \ + while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ + (pl) = gc_plist_hack ((name), s, (pl)); \ +} while (0) DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* Reclaim storage for Lisp objects no longer needed. @@ -4948,16 +4884,6 @@ init_alloc_once_early (void) { int iii; -#ifdef PURESTAT - for (iii = 0; iii < countof (purestats); iii++) - { - if (! purestats[iii]) continue; - purestats[iii]->nobjects = 0; - purestats[iii]->nbytes = 0; - } - purecopying_for_bytecode = 0; -#endif /* PURESTAT */ - last_lrecord_type_index_assigned = -1; for (iii = 0; iii < countof (lrecord_implementations_table); iii++) { diff --git a/src/alloca.s b/src/alloca.s index 3ac4753..17da88f 100644 --- a/src/alloca.s +++ b/src/alloca.s @@ -64,7 +64,7 @@ lose!! data text globl _alloca -_alloca +_alloca move.l (sp)+,a0 ; pop return addr from top of stack move.l (sp)+,d0 ; pop size in bytes from top of stack add.l #ROUND,d0 ; round size up to long word @@ -117,7 +117,7 @@ copy_regs_loop: /* save caller's saved registers */ alloca: #ifdef MOTOROLA_DELTA /* slightly modified version of alloca to motorola sysV/68 pcc - based - compiler. + compiler. this compiler saves used registers relative to %sp instead of %fp. alright, just make new copy of saved register set whenever we allocate new space from stack.. @@ -186,7 +186,7 @@ _alloca: move.l sp,d1 ; get current SP value sub.l d0,d1 ; adjust to reflect required size... sub.l #MAXREG*4,d1 ; ...and space needed for registers - and.l #-4,d1 ; backup to longword boundry + and.l #-4,d1 ; backup to longword boundary move.l sp,a0 ; save old SP value for register copy move.l d1,sp ; set the new SP value tst.b -4096(sp) ; grab an extra page (to cover caller) @@ -256,9 +256,9 @@ alloca: * We have to copy registers, and therefore waste 32 bytes. * * Stack layout: - * new sp -> junk + * new sp -> junk * registers (copy) - * r0 -> new data + * r0 -> new data * | (orig retval) * | (orig arg) * old sp -> regs (orig) diff --git a/src/backtrace.h b/src/backtrace.h index d25ddb3..1f57911 100644 --- a/src/backtrace.h +++ b/src/backtrace.h @@ -46,12 +46,6 @@ struct backtrace If nargs is UNEVALLED, args points to slot holding list of unevalled args */ int pdlcount; /* specpdl_depth () when invoked */ -#ifdef EMACS_BTL - /* The value of a Lisp integer that specifies the symbol being - "invoked" by this node in the backtrace, or 0 if the backtrace - doesn't correspond to a such an invocation */ - int id_number; -#endif char evalargs; /* Nonzero means call value of debugger when done with this operation. */ char debug_on_exit; @@ -116,7 +110,8 @@ struct catchtag struct specbinding { - Lisp_Object symbol, old_value; + Lisp_Object symbol; + Lisp_Object old_value; Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */ }; @@ -132,7 +127,7 @@ struct handler and Fcondition_case thus knows which clause to run. */ Lisp_Object chosen_clause; - /* Used to effect the longjump out to the handler. */ + /* Used to effect the longjmp() out to the handler. */ struct catchtag *tag; /* The next enclosing handler. */ @@ -149,4 +144,179 @@ extern struct specbinding *specpdl_ptr; extern struct catchtag *catchlist; extern struct backtrace *backtrace_list; +/* Most callers should simply use specbind() and unbind_to(), but if + speed is REALLY IMPORTANT, you can use the faster macros below */ +void specbind_magic (Lisp_Object, Lisp_Object); +void grow_specpdl (size_t reserved); +void unbind_to_hairy (int); +extern int specpdl_size; + +/* Inline version of specbind(). + Use this instead of specbind() if speed is sufficiently important + to save the overhead of even a single function call. */ +#define SPECBIND(symbol_object, value_object) do { \ + Lisp_Object SB_symbol = (symbol_object); \ + Lisp_Object SB_newval = (value_object); \ + Lisp_Object SB_oldval; \ + struct Lisp_Symbol *SB_sym; \ + \ + SPECPDL_RESERVE (1); \ + \ + CHECK_SYMBOL (SB_symbol); \ + SB_sym = XSYMBOL (SB_symbol); \ + SB_oldval = SB_sym->value; \ + \ + if (!SYMBOL_VALUE_MAGIC_P (SB_oldval) || UNBOUNDP (SB_oldval)) \ + { \ + /* ### the following test will go away when we have a constant \ + symbol magic object */ \ + if (EQ (SB_symbol, Qnil) || \ + EQ (SB_symbol, Qt) || \ + SYMBOL_IS_KEYWORD (SB_symbol)) \ + reject_constant_symbols (SB_symbol, SB_newval, 0, \ + UNBOUNDP (SB_newval) ? \ + Qmakunbound : Qset); \ + \ + specpdl_ptr->symbol = SB_symbol; \ + specpdl_ptr->old_value = SB_oldval; \ + specpdl_ptr->func = 0; \ + specpdl_ptr++; \ + specpdl_depth_counter++; \ + \ + SB_sym->value = (SB_newval); \ + } \ + else \ + specbind_magic (SB_symbol, SB_newval); \ +} while (0) + +/* An even faster, but less safe inline version of specbind(). + Caller guarantees that: + - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword). + - specpdl_depth_counter >= specpdl_size. + Else we crash. */ +#define SPECBIND_FAST_UNSAFE(symbol_object, value_object) do { \ + Lisp_Object SFU_symbol = (symbol_object); \ + Lisp_Object SFU_newval = (value_object); \ + struct Lisp_Symbol *SFU_sym = XSYMBOL (SFU_symbol); \ + Lisp_Object SFU_oldval = SFU_sym->value; \ + if (!SYMBOL_VALUE_MAGIC_P (SFU_oldval) || UNBOUNDP (SFU_oldval)) \ + { \ + specpdl_ptr->symbol = SFU_symbol; \ + specpdl_ptr->old_value = SFU_oldval; \ + specpdl_ptr->func = 0; \ + specpdl_ptr++; \ + specpdl_depth_counter++; \ + \ + SFU_sym->value = (SFU_newval); \ + } \ + else \ + specbind_magic (SFU_symbol, SFU_newval); \ +} while (0) + +/* Request enough room for SIZE future entries on special binding stack */ +#define SPECPDL_RESERVE(size) do { \ + size_t SR_size = (size); \ + if (specpdl_depth() + SR_size >= specpdl_size) \ + grow_specpdl (SR_size); \ +} while (0) + +/* Inline version of unbind_to(). + Use this instead of unbind_to() if speed is sufficiently important + to save the overhead of even a single function call. + + Most of the time, unbind_to() is called only on ordinary + variables, so optimize for that. */ +#define UNBIND_TO_GCPRO(count, value) do { \ + int UNBIND_TO_count = (count); \ + while (specpdl_depth_counter != UNBIND_TO_count) \ + { \ + struct Lisp_Symbol *sym; \ + --specpdl_ptr; \ + --specpdl_depth_counter; \ + \ + if (specpdl_ptr->func != 0 || \ + ((sym = XSYMBOL (specpdl_ptr->symbol)), \ + SYMBOL_VALUE_MAGIC_P (sym->value))) \ + { \ + struct gcpro gcpro1; \ + GCPRO1 (value); \ + unbind_to_hairy (UNBIND_TO_count); \ + UNGCPRO; \ + break; \ + } \ + \ + sym->value = specpdl_ptr->old_value; \ + } \ +} while (0) + +/* A slightly faster inline version of unbind_to, + that doesn't offer GCPROing services. */ +#define UNBIND_TO(count) do { \ + int UNBIND_TO_count = (count); \ + while (specpdl_depth_counter != UNBIND_TO_count) \ + { \ + struct Lisp_Symbol *sym; \ + --specpdl_ptr; \ + --specpdl_depth_counter; \ + \ + if (specpdl_ptr->func != 0 || \ + ((sym = XSYMBOL (specpdl_ptr->symbol)), \ + SYMBOL_VALUE_MAGIC_P (sym->value))) \ + { \ + unbind_to_hairy (UNBIND_TO_count); \ + break; \ + } \ + \ + sym->value = specpdl_ptr->old_value; \ + } \ +} while (0) + +#ifdef ERROR_CHECK_TYPECHECK +#define CHECK_SPECBIND_VARIABLE assert (specpdl_ptr->func == 0) +#else +#define CHECK_SPECBIND_VARIABLE DO_NOTHING +#endif + +/* Another inline version of unbind_to(). VALUE is GC-protected. + Caller guarantees that: + - all of the elements on the binding stack are variable bindings. + Else we crash. */ +#define UNBIND_TO_GCPRO_VARIABLES_ONLY(count, value) do { \ + int UNBIND_TO_count = (count); \ + while (specpdl_depth_counter != UNBIND_TO_count) \ + { \ + struct Lisp_Symbol *sym; \ + --specpdl_ptr; \ + --specpdl_depth_counter; \ + \ + CHECK_SPECBIND_VARIABLE; \ + sym = XSYMBOL (specpdl_ptr->symbol); \ + if (!SYMBOL_VALUE_MAGIC_P (sym->value)) \ + sym->value = specpdl_ptr->old_value; \ + else \ + { \ + struct gcpro gcpro1; \ + GCPRO1 (value); \ + unbind_to_hairy (UNBIND_TO_count); \ + UNGCPRO; \ + break; \ + } \ + } \ +} while (0) + +/* A faster, but less safe inline version of Fset(). + Caller guarantees that: + - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword). + Else we crash. */ +#define FSET_FAST_UNSAFE(sym, newval) do { \ + Lisp_Object FFU_sym = (sym); \ + Lisp_Object FFU_newval = (newval); \ + struct Lisp_Symbol *FFU_symbol = XSYMBOL (FFU_sym); \ + Lisp_Object FFU_oldval = FFU_symbol->value; \ + if (!SYMBOL_VALUE_MAGIC_P (FFU_oldval) || UNBOUNDP (FFU_oldval)) \ + FFU_symbol->value = FFU_newval; \ + else \ + Fset (FFU_sym, FFU_newval); \ +} while (0) + #endif /* _XEMACS_BACKTRACE_H_ */ diff --git a/src/balloon_help.c b/src/balloon_help.c index b73a711..8efbbeb 100644 --- a/src/balloon_help.c +++ b/src/balloon_help.c @@ -32,7 +32,6 @@ Boston, MA 02111-1307, USA. */ #include #include -#include #include #include @@ -86,8 +85,6 @@ static GC b_maskGC; static CONST char* b_text; static int b_width, b_height; -static int b_lastX, b_lastY; - static XtIntervalId b_timer; static unsigned long b_delay; @@ -364,11 +361,8 @@ show_help (XtPointer data, XtIntervalId* id) /* make sure it is still ok with offset */ shape = get_shape (shape, x, y, b_width, b_height, b_screenWidth, b_screenHeight); - b_lastX = x; - b_lastY = y; b_lastShape = shape; - make_mask (shape, x, y, b_width, b_height); XShapeCombineMask (b_dpy, b_win, ShapeBounding, 0, 0, b_mask, ShapeSet); @@ -598,9 +592,6 @@ balloon_help_move_to_pointer (void) if (shape == b_lastShape) { - b_lastX = x; - b_lastY = y; - XMoveWindow (b_dpy, b_win, shape & SHAPE_CONE_LEFT ? x : x - b_width, shape & SHAPE_CONE_TOP ? y : y - b_height); diff --git a/src/buffer.c b/src/buffer.c index 7b88d68..d235117 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -80,6 +80,7 @@ Boston, MA 02111-1307, USA. */ #ifdef REGION_CACHE_NEEDS_WORK #include "region-cache.h" #endif +#include "specifier.h" #include "syntax.h" #include "sysdep.h" /* for getwd */ #include "window.h" @@ -227,13 +228,13 @@ mark_buffer (Lisp_Object obj, void (*markobj) (Lisp_Object)) undo_threshold, undo_high_threshold); -#define MARKED_SLOT(x) ((markobj) (buf->x)); +#define MARKED_SLOT(x) ((void) (markobj (buf->x))); #include "bufslots.h" #undef MARKED_SLOT - ((markobj) (buf->extent_info)); + markobj (buf->extent_info); if (buf->text) - ((markobj) (buf->text->line_number_cache)); + markobj (buf->text->line_number_cache); /* Don't mark normally through the children slot. (Actually, in this case, it doesn't matter.) */ @@ -310,12 +311,9 @@ returned instead. */ (frame)) { - Lisp_Object list; - if (EQ (frame, Qt)) - list = Vbuffer_alist; - else - list = decode_frame (frame)->buffer_alist; - return Fmapcar (Qcdr, list); + return Fmapcar (Qcdr, + EQ (frame, Qt) ? Vbuffer_alist : + decode_frame (frame)->buffer_alist); } Lisp_Object @@ -435,7 +433,7 @@ the search will still be done on `buffer-file-name'. (filename)) { /* This function can GC. GC checked 1997.04.06. */ - REGISTER Lisp_Object tail, buf, tem; + REGISTER Lisp_Object buf; struct gcpro gcpro1; #ifdef I18N3 @@ -476,18 +474,20 @@ the search will still be done on `buffer-file-name'. NUNGCPRO; } - LIST_LOOP (tail, Vbuffer_alist) - { - buf = Fcdr (XCAR (tail)); - if (!BUFFERP (buf)) continue; - if (!STRINGP (XBUFFER (buf)->filename)) continue; - tem = Fstring_equal (filename, - (find_file_compare_truenames - ? XBUFFER (buf)->file_truename - : XBUFFER (buf)->filename)); - if (!NILP (tem)) - return buf; - } + { + Lisp_Object elt; + LIST_LOOP_2 (elt, Vbuffer_alist) + { + buf = Fcdr (elt); + if (!BUFFERP (buf)) continue; + if (!STRINGP (XBUFFER (buf)->filename)) continue; + if (!NILP (Fstring_equal (filename, + (find_file_compare_truenames + ? XBUFFER (buf)->file_truename + : XBUFFER (buf)->filename)))) + return buf; + } + } return Qnil; } @@ -579,8 +579,8 @@ finish_init_buffer (struct buffer *b, Lisp_Object name) init_buffer_markers (b); b->generated_modeline_string = Fmake_string (make_int (84), make_int (' ')); - b->modeline_extent_table = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQ); + b->modeline_extent_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, + HASH_TABLE_EQ); return buf; } @@ -2014,81 +2014,55 @@ List of functions called with no args to query before killing a buffer. delete_auto_save_files = 1; } -/* DOC is ignored because it is snagged and recorded externally - * by make-docfile */ +/* The docstrings for DEFVAR_* are recorded externally by make-docfile. */ + /* Renamed from DEFVAR_PER_BUFFER because FSFmacs D_P_B takes - * a bogus extra arg, which confuses an otherwise identical make-docfile.c */ + a bogus extra arg, which confuses an otherwise identical make-docfile.c */ + /* Declaring this stuff as const produces 'Cannot reinitialize' messages from SunPro C's fix-and-continue feature (a way neato feature that makes debugging unbelievably more bearable) */ -#define DEFVAR_BUFFER_LOCAL(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CURRENT_BUFFER_FORWARD }, 0 }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -#define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CURRENT_BUFFER_FORWARD }, magicfun }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -#define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, 0 }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -#define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) do{\ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, magicfun }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -static void -defvar_buffer_local (CONST char *namestring, - CONST struct symbol_value_forward *m) -{ - int offset = ((char *)symbol_value_forward_forward (m) - - (char *)&buffer_local_flags); - - defvar_mumble (namestring, m, sizeof (*m)); - - *((Lisp_Object *)(offset + (char *)XBUFFER (Vbuffer_local_symbols))) - = intern (namestring); -} - -/* DOC is ignored because it is snagged and recorded externally - * by make-docfile */ -#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_BUFFER_FORWARD }, 0 }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) - -#define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_BUFFER_FORWARD }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) +#define DEFVAR_BUFFER_LOCAL_1(lname, field_name, forward_type, magicfun) do { \ + static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ + = { { { symbol_value_forward_lheader_initializer, \ + (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ + forward_type }, magicfun }; \ + { \ + int offset = ((char *)symbol_value_forward_forward (&I_hate_C) - \ + (char *)&buffer_local_flags); \ + defvar_magic (lname, &I_hate_C); \ + \ + *((Lisp_Object *)(offset + (char *)XBUFFER (Vbuffer_local_symbols))) \ + = intern (lname); \ + } \ +} while (0) + +#define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \ + DEFVAR_BUFFER_LOCAL_1 (lname, field_name, \ + SYMVAL_CURRENT_BUFFER_FORWARD, magicfun) +#define DEFVAR_BUFFER_LOCAL(lname, field_name) \ + DEFVAR_BUFFER_LOCAL_MAGIC (lname, field_name, 0) +#define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \ + DEFVAR_BUFFER_LOCAL_1 (lname, field_name, \ + SYMVAL_CONST_CURRENT_BUFFER_FORWARD, magicfun) +#define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) \ + DEFVAR_CONST_BUFFER_LOCAL_MAGIC (lname, field_name, 0) + +#define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) \ + DEFVAR_SYMVAL_FWD (lname, &(buffer_local_flags.field_name), \ + SYMVAL_DEFAULT_BUFFER_FORWARD, magicfun) +#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) \ + DEFVAR_BUFFER_DEFAULTS_MAGIC (lname, field_name, 0) static void nuke_all_buffer_slots (struct buffer *b, Lisp_Object zap) { zero_lcrecord (b); + b->extent_info = Qnil; + b->indirect_children = Qnil; + b->own_text.line_number_cache = Qnil; + #define MARKED_SLOT(x) b->x = (zap); #include "bufslots.h" #undef MARKED_SLOT @@ -2117,15 +2091,17 @@ complex_vars_of_buffer (void) defs->major_mode = Qfundamental_mode; defs->mode_name = QSFundamental; defs->abbrev_table = Qnil; /* real default setup by Lisp code */ - defs->downcase_table = Vascii_downcase_table; - defs->upcase_table = Vascii_upcase_table; + + defs->downcase_table = Vascii_downcase_table; + defs->upcase_table = Vascii_upcase_table; defs->case_canon_table = Vascii_canon_table; - defs->case_eqv_table = Vascii_eqv_table; + defs->case_eqv_table = Vascii_eqv_table; #ifdef MULE - defs->mirror_downcase_table = Vmirror_ascii_downcase_table; - defs->mirror_upcase_table = Vmirror_ascii_upcase_table; + defs->mirror_downcase_table = Vmirror_ascii_downcase_table; + defs->mirror_upcase_table = Vmirror_ascii_upcase_table; defs->mirror_case_canon_table = Vmirror_ascii_canon_table; - defs->mirror_case_eqv_table = Vmirror_ascii_eqv_table; + defs->mirror_case_eqv_table = Vmirror_ascii_eqv_table; + defs->category_table = Vstandard_category_table; #endif /* MULE */ defs->syntax_table = Vstandard_syntax_table; @@ -2159,7 +2135,7 @@ complex_vars_of_buffer (void) */ Lisp_Object always_local_no_default = make_int (0); Lisp_Object always_local_resettable = make_int (-1); - Lisp_Object resettable = make_int (-3); + Lisp_Object resettable = make_int (-3); /* Assign the local-flags to the slots that have default values. The local flag is a bit that is used in the buffer @@ -2168,58 +2144,58 @@ complex_vars_of_buffer (void) buffer. */ nuke_all_buffer_slots (&buffer_local_flags, make_int (-2)); - buffer_local_flags.filename = always_local_no_default; - buffer_local_flags.directory = always_local_no_default; - buffer_local_flags.backed_up = always_local_no_default; - buffer_local_flags.saved_size = always_local_no_default; + buffer_local_flags.filename = always_local_no_default; + buffer_local_flags.directory = always_local_no_default; + buffer_local_flags.backed_up = always_local_no_default; + buffer_local_flags.saved_size = always_local_no_default; buffer_local_flags.auto_save_file_name = always_local_no_default; - buffer_local_flags.read_only = always_local_no_default; + buffer_local_flags.read_only = always_local_no_default; - buffer_local_flags.major_mode = always_local_resettable; - buffer_local_flags.mode_name = always_local_resettable; - buffer_local_flags.undo_list = always_local_no_default; + buffer_local_flags.major_mode = always_local_resettable; + buffer_local_flags.mode_name = always_local_resettable; + buffer_local_flags.undo_list = always_local_no_default; #if 0 /* FSFmacs */ - buffer_local_flags.mark_active = always_local_resettable; + buffer_local_flags.mark_active = always_local_resettable; #endif buffer_local_flags.point_before_scroll = always_local_resettable; - buffer_local_flags.file_truename = always_local_no_default; - buffer_local_flags.invisibility_spec = always_local_resettable; - buffer_local_flags.file_format = always_local_resettable; + buffer_local_flags.file_truename = always_local_no_default; + buffer_local_flags.invisibility_spec = always_local_resettable; + buffer_local_flags.file_format = always_local_resettable; buffer_local_flags.generated_modeline_string = always_local_no_default; - buffer_local_flags.keymap = resettable; - buffer_local_flags.downcase_table = resettable; - buffer_local_flags.upcase_table = resettable; + buffer_local_flags.keymap = resettable; + buffer_local_flags.downcase_table = resettable; + buffer_local_flags.upcase_table = resettable; buffer_local_flags.case_canon_table = resettable; - buffer_local_flags.case_eqv_table = resettable; - buffer_local_flags.syntax_table = resettable; + buffer_local_flags.case_eqv_table = resettable; + buffer_local_flags.syntax_table = resettable; #ifdef MULE - buffer_local_flags.category_table = resettable; + buffer_local_flags.category_table = resettable; #endif - buffer_local_flags.modeline_format = make_int (1); - buffer_local_flags.abbrev_mode = make_int (2); - buffer_local_flags.overwrite_mode = make_int (4); - buffer_local_flags.case_fold_search = make_int (8); - buffer_local_flags.auto_fill_function = make_int (0x10); - buffer_local_flags.selective_display = make_int (0x20); - buffer_local_flags.selective_display_ellipses = make_int (0x40); - buffer_local_flags.tab_width = make_int (0x80); - buffer_local_flags.truncate_lines = make_int (0x100); - buffer_local_flags.ctl_arrow = make_int (0x200); - buffer_local_flags.fill_column = make_int (0x400); - buffer_local_flags.left_margin = make_int (0x800); - buffer_local_flags.abbrev_table = make_int (0x1000); + buffer_local_flags.modeline_format = make_int (1<<0); + buffer_local_flags.abbrev_mode = make_int (1<<1); + buffer_local_flags.overwrite_mode = make_int (1<<2); + buffer_local_flags.case_fold_search = make_int (1<<3); + buffer_local_flags.auto_fill_function = make_int (1<<4); + buffer_local_flags.selective_display = make_int (1<<5); + buffer_local_flags.selective_display_ellipses = make_int (1<<6); + buffer_local_flags.tab_width = make_int (1<<7); + buffer_local_flags.truncate_lines = make_int (1<<8); + buffer_local_flags.ctl_arrow = make_int (1<<9); + buffer_local_flags.fill_column = make_int (1<<10); + buffer_local_flags.left_margin = make_int (1<<11); + buffer_local_flags.abbrev_table = make_int (1<<12); #ifdef REGION_CACHE_NEEDS_WORK - buffer_local_flags.cache_long_line_scans = make_int (0x2000); + buffer_local_flags.cache_long_line_scans = make_int (1<<13); #endif #ifdef FILE_CODING - buffer_local_flags.buffer_file_coding_system = make_int (0x4000); + buffer_local_flags.buffer_file_coding_system = make_int (1<<14); #endif - /* #### Warning, 0x4000000 (that's six zeroes) is the largest number - currently allowable due to the XINT() handling of this value. - With some rearrangement you can get 4 more bits. */ + /* #### Warning: 1<<28 is the largest number currently allowable + due to the XINT() handling of this value. With some + rearrangement you can get 3 more bits. */ } DEFVAR_BUFFER_DEFAULTS ("default-modeline-format", modeline_format /* @@ -2429,7 +2405,7 @@ its mnemonic abbreviation. The default value for this variable (which is normally used for buffers without associated files) is also used when automatic detection of a file's encoding is called for and there was no -discernable encoding in the file (i.e. it was entirely or almost +discernible encoding in the file (i.e. it was entirely or almost entirely ASCII). The default value should generally *not* be set to nil (equivalent to `no-conversion'), because if extended characters are ever inserted into the buffer, they will be lost when the file is @@ -2457,7 +2433,7 @@ particular operation, you should bind the variable variables just mentioned, which are intended to be used for global environment specification. */ ); -#endif +#endif /* FILE_CODING */ DEFVAR_BUFFER_LOCAL ("auto-fill-function", auto_fill_function /* Function called (if non-nil) to perform auto-fill. @@ -2744,7 +2720,7 @@ init_initial_directory (void) initial_directory[rc + 1] = '\0'; } /* XEmacs change: store buffer's default directory - using prefered (i.e. as defined at compile-time) + using preferred (i.e. as defined at compile-time) directory separator. --marcpa */ #ifdef DOS_NT #define CORRECT_DIR_SEPS(s) \ diff --git a/src/buffer.h b/src/buffer.h index 0a7b634..f9bf6c1 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -237,6 +237,7 @@ DECLARE_LRECORD (buffer, struct buffer); x = wrong_type_argument (Qbuffer_live_p, (x)); \ } while (0) + #define BUFFER_BASE_BUFFER(b) ((b)->base_buffer ? (b)->base_buffer : (b)) /* Map over buffers sharing the same text as MPS_BUF. MPS_BUFVAR is a @@ -255,6 +256,13 @@ for (mps_bufcons = Qunbound, \ ) + +/************************************************************************/ +/* */ +/* working with raw internal-format data */ +/* */ +/************************************************************************/ + /* NOTE: In all the following macros, we follow these rules concerning multiple evaluation of the arguments: @@ -270,52 +278,44 @@ for (mps_bufcons = Qunbound, \ denoted with the word "unsafe" in their name and are generally meant to be called only by other macros that have already stored the calling values in temporary variables. - */ -/************************************************************************/ -/* */ -/* working with raw internal-format data */ -/* */ -/************************************************************************/ - -/* Use these on contiguous strings of data. If the text you're - operating on is known to come from a buffer, use the buffer-level - functions below -- they know about the gap and may be more - efficient. */ -/* Functions are as follows: + Use the following functions/macros on contiguous strings of data. + If the text you're operating on is known to come from a buffer, use + the buffer-level functions below -- they know about the gap and may + be more efficient. - (A) For working with charptr's (pointers to internally-formatted text): - ----------------------------------------------------------------------- + (A) For working with charptr's (pointers to internally-formatted text): + ----------------------------------------------------------------------- - VALID_CHARPTR_P(ptr): + VALID_CHARPTR_P (ptr): Given a charptr, does it point to the beginning of a character? - ASSERT_VALID_CHARPTR(ptr): + ASSERT_VALID_CHARPTR (ptr): If error-checking is enabled, assert that the given charptr - points to the beginning of a character. Otherwise, do nothing. + points to the beginning of a character. Otherwise, do nothing. - INC_CHARPTR(ptr): + INC_CHARPTR (ptr): Given a charptr (assumed to point at the beginning of a character), modify that pointer so it points to the beginning of the next character. - DEC_CHARPTR(ptr): + DEC_CHARPTR (ptr): Given a charptr (assumed to point at the beginning of a character or at the very end of the text), modify that pointer so it points to the beginning of the previous character. - VALIDATE_CHARPTR_BACKWARD(ptr): + VALIDATE_CHARPTR_BACKWARD (ptr): Make sure that PTR is pointing to the beginning of a character. - If not, back up until this is the case. Note that there are not + If not, back up until this is the case. Note that there are not too many places where it is legitimate to do this sort of thing. It's an error if you're passed an "invalid" char * pointer. NOTE: PTR *must* be pointing to a valid part of the string (i.e. not the very end, unless the string is zero-terminated or something) in order for this function to not cause crashes. - VALIDATE_CHARPTR_FORWARD(ptr): + VALIDATE_CHARPTR_FORWARD (ptr): Make sure that PTR is pointing to the beginning of a character. If not, move forward until this is the case. Note that there are not too many places where it is legitimate to do this sort @@ -327,38 +327,34 @@ for (mps_bufcons = Qunbound, \ section of internally-formatted text: -------------------------------------------------------------- - bytecount_to_charcount(ptr, nbi): + bytecount_to_charcount (ptr, nbi): Given a pointer to a text string and a length in bytes, return the equivalent length in characters. - charcount_to_bytecount(ptr, nch): + charcount_to_bytecount (ptr, nch): Given a pointer to a text string and a length in characters, return the equivalent length in bytes. - charptr_n_addr(ptr, n): + charptr_n_addr (ptr, n): Return a pointer to the beginning of the character offset N (in characters) from PTR. - charptr_length(ptr): - Given a zero-terminated pointer to Emacs characters, - return the number of Emacs characters contained within. - (C) For retrieving or changing the character pointed to by a charptr: --------------------------------------------------------------------- - charptr_emchar(ptr): + charptr_emchar (ptr): Retrieve the character pointed to by PTR as an Emchar. - charptr_emchar_n(ptr, n): + charptr_emchar_n (ptr, n): Retrieve the character at offset N (in characters) from PTR, as an Emchar. - set_charptr_emchar(ptr, ch): + set_charptr_emchar (ptr, ch): Store the character CH (an Emchar) as internally-formatted text starting at PTR. Return the number of bytes stored. - charptr_copy_char(ptr, ptr2): + charptr_copy_char (ptr, ptr2): Retrieve the character pointed to by PTR and store it as internally-formatted text in PTR2. @@ -370,25 +366,16 @@ for (mps_bufcons = Qunbound, \ in mule-charset.h, for retrieving the charset of an Emchar and such. These are only valid when MULE is defined.] - valid_char_p(ch): + valid_char_p (ch): Return whether the given Emchar is valid. - CHARP(ch): - Return whether the given Lisp_Object is a valid character. - This is approximately the same as saying the Lisp_Object is - an int whose value is a valid Emchar. (But not exactly - because when MULE is not defined, we allow arbitrary values - in all but the lowest 8 bits and mask them off, for backward - compatibility.) - - CHECK_CHAR_COERCE_INT(ch): - Signal an error if CH is not a valid character as per CHARP(). - Also canonicalize the value into a valid Emchar, as necessary. - (This only means anything when MULE is not defined.) + CHARP (ch): + Return whether the given Lisp_Object is a character. - COERCE_CHAR(ch): - Coerce an object that is known to satisfy CHARP() into a - valid Emchar. + CHECK_CHAR_COERCE_INT (ch): + Signal an error if CH is not a valid character or integer Lisp_Object. + If CH is an integer Lisp_Object, convert it to a character Lisp_Object, + but merely by repackaging, without performing tests for char validity. MAX_EMCHAR_LEN: Maximum number of buffer bytes per Emacs character. @@ -419,38 +406,32 @@ for (mps_bufcons = Qunbound, \ method because it doesn't have easy access to the first byte of the character it's moving over. */ -#define real_inc_charptr_fun(ptr) \ - ((ptr) += REP_BYTES_BY_FIRST_BYTE (* (unsigned char *) (ptr))) -#ifdef ERROR_CHECK_BUFPOS -#define inc_charptr_fun(ptr) (ASSERT_VALID_CHARPTR (ptr), \ - real_inc_charptr_fun (ptr)) -#else -#define inc_charptr_fun(ptr) real_inc_charptr_fun (ptr) -#endif +#define REAL_INC_CHARPTR(ptr) \ + ((void) ((ptr) += REP_BYTES_BY_FIRST_BYTE (* (unsigned char *) (ptr)))) -#define REAL_INC_CHARPTR(ptr) ((void) (real_inc_charptr_fun (ptr))) +#define REAL_DEC_CHARPTR(ptr) do { \ + (ptr)--; \ +} while (!VALID_CHARPTR_P (ptr)) +#ifdef ERROR_CHECK_BUFPOS #define INC_CHARPTR(ptr) do { \ ASSERT_VALID_CHARPTR (ptr); \ REAL_INC_CHARPTR (ptr); \ } while (0) -#define REAL_DEC_CHARPTR(ptr) do { \ - (ptr)--; \ -} while (!VALID_CHARPTR_P (ptr)) - -#ifdef ERROR_CHECK_BUFPOS -#define DEC_CHARPTR(ptr) do { \ - CONST Bufbyte *__dcptr__ = (ptr); \ - CONST Bufbyte *__dcptr2__ = __dcptr__; \ - REAL_DEC_CHARPTR (__dcptr2__); \ - assert (__dcptr__ - __dcptr2__ == \ - REP_BYTES_BY_FIRST_BYTE (*__dcptr2__)); \ - (ptr) = __dcptr2__; \ +#define DEC_CHARPTR(ptr) do { \ + CONST Bufbyte *dc_ptr1 = (ptr); \ + CONST Bufbyte *dc_ptr2 = dc_ptr1; \ + REAL_DEC_CHARPTR (dc_ptr2); \ + assert (dc_ptr1 - dc_ptr2 == \ + REP_BYTES_BY_FIRST_BYTE (*dc_ptr2)); \ + (ptr) = dc_ptr2; \ } while (0) -#else + +#else /* ! ERROR_CHECK_BUFPOS */ +#define INC_CHARPTR(ptr) REAL_INC_CHARPTR (ptr) #define DEC_CHARPTR(ptr) REAL_DEC_CHARPTR (ptr) -#endif +#endif /* ! ERROR_CHECK_BUFPOS */ #ifdef MULE @@ -462,11 +443,11 @@ for (mps_bufcons = Qunbound, \ the end of the string. */ #define VALIDATE_CHARPTR_FORWARD(ptr) do { \ - Bufbyte *__vcfptr__ = (ptr); \ - VALIDATE_CHARPTR_BACKWARD (__vcfptr__); \ - if (__vcfptr__ != (ptr)) \ + Bufbyte *vcf_ptr = (ptr); \ + VALIDATE_CHARPTR_BACKWARD (vcf_ptr); \ + if (vcf_ptr != (ptr)) \ { \ - (ptr) = __vcfptr__; \ + (ptr) = vcf_ptr; \ INC_CHARPTR (ptr); \ } \ } while (0) @@ -488,14 +469,6 @@ charptr_n_addr (CONST Bufbyte *ptr, Charcount offset) return ptr + charcount_to_bytecount (ptr, offset); } -INLINE Charcount charptr_length (CONST Bufbyte *ptr); -INLINE Charcount -charptr_length (CONST Bufbyte *ptr) -{ - return bytecount_to_charcount (ptr, strlen ((CONST char *) ptr)); -} - - /* -------------------------------------------------------------------- */ /* (C) For retrieving or changing the character pointed to by a charptr */ /* -------------------------------------------------------------------- */ @@ -561,12 +534,12 @@ INLINE int valid_char_p (Emchar ch); INLINE int valid_char_p (Emchar ch) { - return (ch >= 0 && ch <= 255) || non_ascii_valid_char_p (ch); + return ((unsigned int) (ch) <= 0xff) || non_ascii_valid_char_p (ch); } #else /* not MULE */ -#define valid_char_p(ch) ((unsigned int) (ch) <= 255) +#define valid_char_p(ch) ((unsigned int) (ch) <= 0xff) #endif /* not MULE */ @@ -869,11 +842,10 @@ memind_to_bytind (struct buffer *buf, Memind x) results with stupid compilers. */ #ifdef MULE -# define VALIDATE_BYTIND_BACKWARD(buf, x) do \ -{ \ - Bufbyte *__ibptr = BI_BUF_BYTE_ADDRESS (buf, x); \ - while (!BUFBYTE_FIRST_BYTE_P (*__ibptr)) \ - __ibptr--, (x)--; \ +# define VALIDATE_BYTIND_BACKWARD(buf, x) do { \ + Bufbyte *VBB_ptr = BI_BUF_BYTE_ADDRESS (buf, x); \ + while (!BUFBYTE_FIRST_BYTE_P (*VBB_ptr)) \ + VBB_ptr--, (x)--; \ } while (0) #else # define VALIDATE_BYTIND_BACKWARD(buf, x) @@ -885,11 +857,10 @@ memind_to_bytind (struct buffer *buf, Memind x) results with stupid compilers. */ #ifdef MULE -# define VALIDATE_BYTIND_FORWARD(buf, x) do \ -{ \ - Bufbyte *__ibptr = BI_BUF_BYTE_ADDRESS (buf, x); \ - while (!BUFBYTE_FIRST_BYTE_P (*__ibptr)) \ - __ibptr++, (x)++; \ +# define VALIDATE_BYTIND_FORWARD(buf, x) do { \ + Bufbyte *VBF_ptr = BI_BUF_BYTE_ADDRESS (buf, x); \ + while (!BUFBYTE_FIRST_BYTE_P (*VBF_ptr)) \ + VBF_ptr++, (x)++; \ } while (0) #else # define VALIDATE_BYTIND_FORWARD(buf, x) @@ -1162,7 +1133,7 @@ Bufbyte *convert_from_external_format (CONST Extbyte *ptr, Extcount gceda_len_out; \ CONST Bufbyte *gceda_ptr_in = (ptr); \ Extbyte *gceda_ptr_out = \ - convert_to_external_format (gceda_ptr_in, gceda_len_in, \ + convert_to_external_format (gceda_ptr_in, gceda_len_in, \ &gceda_len_out, fmt); \ /* If the new string is identical to the old (will be the case most \ of the time), just return the same string back. This saves \ @@ -1173,14 +1144,13 @@ Bufbyte *convert_from_external_format (CONST Extbyte *ptr, !memcmp (gceda_ptr_in, gceda_ptr_out, gceda_len_out)) \ { \ (ptr_out) = (Extbyte *) gceda_ptr_in; \ - (len_out) = (Extcount) gceda_len_in; \ } \ else \ { \ (ptr_out) = (Extbyte *) alloca (1 + gceda_len_out); \ memcpy ((void *) ptr_out, gceda_ptr_out, 1 + gceda_len_out); \ - (len_out) = (Extcount) gceda_len_out; \ } \ + (len_out) = gceda_len_out; \ } while (0) #else /* ! MULE */ @@ -1240,9 +1210,9 @@ Bufbyte *convert_from_external_format (CONST Extbyte *ptr, { \ Extcount gcida_len_in = (Extcount) (len); \ Bytecount gcida_len_out; \ - CONST Extbyte *gcida_ptr_in = (ptr); \ + CONST Extbyte *gcida_ptr_in = (ptr); \ Bufbyte *gcida_ptr_out = \ - convert_from_external_format (gcida_ptr_in, gcida_len_in, \ + convert_from_external_format (gcida_ptr_in, gcida_len_in, \ &gcida_len_out, fmt); \ /* If the new string is identical to the old (will be the case most \ of the time), just return the same string back. This saves \ @@ -1253,14 +1223,13 @@ Bufbyte *convert_from_external_format (CONST Extbyte *ptr, !memcmp (gcida_ptr_in, gcida_ptr_out, gcida_len_out)) \ { \ (ptr_out) = (Bufbyte *) gcida_ptr_in; \ - (len_out) = (Bytecount) gcida_len_in; \ } \ else \ { \ (ptr_out) = (Extbyte *) alloca (1 + gcida_len_out); \ memcpy ((void *) ptr_out, gcida_ptr_out, 1 + gcida_len_out); \ - (len_out) = gcida_len_out; \ } \ + (len_out) = gcida_len_out; \ } while (0) #else /* ! MULE */ @@ -1604,7 +1573,7 @@ void r_alloc_free (unsigned char **); #else /* !REL_ALLOC */ #define BUFFER_ALLOC(data,size)\ - ((void) (data = xnew_array (Bufbyte, size))) + (data = xnew_array (Bufbyte, size)) #define BUFFER_REALLOC(data,size)\ ((Bufbyte *) xrealloc (data, (size) * sizeof(Bufbyte))) /* Avoid excess parentheses, or syntax errors may rear their heads. */ @@ -1634,9 +1603,9 @@ int emchar_string_displayed_columns (CONST Emchar *str, Charcount len); void convert_bufbyte_string_into_emchar_dynarr (CONST Bufbyte *str, Bytecount len, Emchar_dynarr *dyn); -int convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, - Bytecount len, - Emchar *arr); +Charcount convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, + Bytecount len, + Emchar *arr); void convert_emchar_string_into_bufbyte_dynarr (Emchar *arr, int nels, Bufbyte_dynarr *dyn); Bufbyte *convert_emchar_string_into_malloced_string (Emchar *arr, int nels, @@ -1713,9 +1682,9 @@ int map_over_sharing_buffers (struct buffer *buf, typically used to convert between uppercase and lowercase. For compatibility reasons, trt tables are currently in the form of a Lisp string of 256 characters, specifying the conversion for each - of the first 256 Emacs characters (i.e. the 256 extended-ASCII - characters). This should be generalized at some point to support - conversions for all of the allowable Mule characters. + of the first 256 Emacs characters (i.e. the 256 Latin-1 characters). + This should be generalized at some point to support conversions for + all of the allowable Mule characters. */ /* The _1 macros are named as such because they assume that you have @@ -1808,7 +1777,7 @@ UPCASE (struct buffer *buf, Emchar ch) return (DOWNCASE_TABLE_OF (buf, ch) == ch) ? UPCASE_TABLE_OF (buf, ch) : ch; } -/* Upcase a character known to be not upper case. */ +/* Upcase a character known to be not upper case. Unused. */ #define UPCASE1(buf, ch) UPCASE_TABLE_OF (buf, ch) diff --git a/src/bufslots.h b/src/bufslots.h index e3e4b16..88f5daf 100644 --- a/src/bufslots.h +++ b/src/bufslots.h @@ -69,7 +69,7 @@ Boston, MA 02111-1307, USA. */ Specifically, this lists those variables that have a buffer-local value in this buffer: i.e. those whose value does not shadow the default value. - (Remember that for any particlar variable created + (Remember that for any particular variable created with `make-local-variable' or `make-variable-buffer-local', it will have a per-buffer value in some buffers and a default value in others.) diff --git a/src/bytecode.c b/src/bytecode.c index 3cb169a..b5111d1 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1,4 +1,5 @@ /* Execution of byte code produced by bytecomp.el. + Implementation of compiled-function objects. Copyright (C) 1992, 1993 Free Software Foundation, Inc. This file is part of XEmacs. @@ -27,7 +28,7 @@ Boston, MA 02111-1307, USA. */ FSF: long ago. -hacked on by jwz@netscape.com 17-jun-91 +hacked on by jwz@netscape.com 1991-06 o added a compile-time switch to turn on simple sanity checking; o put back the obsolete byte-codes for error-detection; o added a new instruction, unbind_all, which I will use for @@ -41,25 +42,198 @@ by Hallvard: o added relative jump instructions; o all conditionals now only do QUIT if they jump. - Ben Wing: some changes for Mule, June 1995. + Ben Wing: some changes for Mule, 1995-06. + + Martin Buchholz: performance hacking, 1998-09. + See Internals Manual, Evaluation. */ #include #include "lisp.h" +#include "backtrace.h" #include "buffer.h" +#include "bytecode.h" +#include "opaque.h" #include "syntax.h" -/* - * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for - * debugging the byte compiler...) Somewhat surprisingly, defining this - * makes Fbyte_code about 8% slower. - * - * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. - */ -/* This isn't defined in FSF Emacs and isn't defined in XEmacs v19 */ +#include +#include + +EXFUN (Ffetch_bytecode, 1); + +Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; + +enum Opcode /* Byte codes */ +{ + Bvarref = 010, + Bvarset = 020, + Bvarbind = 030, + Bcall = 040, + Bunbind = 050, + + Bnth = 070, + Bsymbolp = 071, + Bconsp = 072, + Bstringp = 073, + Blistp = 074, + Bold_eq = 075, + Bold_memq = 076, + Bnot = 077, + Bcar = 0100, + Bcdr = 0101, + Bcons = 0102, + Blist1 = 0103, + Blist2 = 0104, + Blist3 = 0105, + Blist4 = 0106, + Blength = 0107, + Baref = 0110, + Baset = 0111, + Bsymbol_value = 0112, + Bsymbol_function = 0113, + Bset = 0114, + Bfset = 0115, + Bget = 0116, + Bsubstring = 0117, + Bconcat2 = 0120, + Bconcat3 = 0121, + Bconcat4 = 0122, + Bsub1 = 0123, + Badd1 = 0124, + Beqlsign = 0125, + Bgtr = 0126, + Blss = 0127, + Bleq = 0130, + Bgeq = 0131, + Bdiff = 0132, + Bnegate = 0133, + Bplus = 0134, + Bmax = 0135, + Bmin = 0136, + Bmult = 0137, + + Bpoint = 0140, + Beq = 0141, /* was Bmark, + but no longer generated as of v18 */ + Bgoto_char = 0142, + Binsert = 0143, + Bpoint_max = 0144, + Bpoint_min = 0145, + Bchar_after = 0146, + Bfollowing_char = 0147, + Bpreceding_char = 0150, + Bcurrent_column = 0151, + Bindent_to = 0152, + Bequal = 0153, /* was Bscan_buffer, + but no longer generated as of v18 */ + Beolp = 0154, + Beobp = 0155, + Bbolp = 0156, + Bbobp = 0157, + Bcurrent_buffer = 0160, + Bset_buffer = 0161, + Bsave_current_buffer = 0162, /* was Bread_char, + but no longer generated as of v19 */ + Bmemq = 0163, /* was Bset_mark, + but no longer generated as of v18 */ + Binteractive_p = 0164, /* Needed since interactive-p takes + unevalled args */ + Bforward_char = 0165, + Bforward_word = 0166, + Bskip_chars_forward = 0167, + Bskip_chars_backward = 0170, + Bforward_line = 0171, + Bchar_syntax = 0172, + Bbuffer_substring = 0173, + Bdelete_region = 0174, + Bnarrow_to_region = 0175, + Bwiden = 0176, + Bend_of_line = 0177, + + Bconstant2 = 0201, + Bgoto = 0202, + Bgotoifnil = 0203, + Bgotoifnonnil = 0204, + Bgotoifnilelsepop = 0205, + Bgotoifnonnilelsepop = 0206, + Breturn = 0207, + Bdiscard = 0210, + Bdup = 0211, + + Bsave_excursion = 0212, + Bsave_window_excursion= 0213, + Bsave_restriction = 0214, + Bcatch = 0215, + + Bunwind_protect = 0216, + Bcondition_case = 0217, + Btemp_output_buffer_setup = 0220, + Btemp_output_buffer_show = 0221, + + Bunbind_all = 0222, + + Bset_marker = 0223, + Bmatch_beginning = 0224, + Bmatch_end = 0225, + Bupcase = 0226, + Bdowncase = 0227, + + Bstring_equal = 0230, + Bstring_lessp = 0231, + Bold_equal = 0232, + Bnthcdr = 0233, + Belt = 0234, + Bold_member = 0235, + Bold_assq = 0236, + Bnreverse = 0237, + Bsetcar = 0240, + Bsetcdr = 0241, + Bcar_safe = 0242, + Bcdr_safe = 0243, + Bnconc = 0244, + Bquo = 0245, + Brem = 0246, + Bnumberp = 0247, + Bintegerp = 0250, + + BRgoto = 0252, + BRgotoifnil = 0253, + BRgotoifnonnil = 0254, + BRgotoifnilelsepop = 0255, + BRgotoifnonnilelsepop = 0256, + + BlistN = 0257, + BconcatN = 0260, + BinsertN = 0261, + Bmember = 0266, /* new in v20 */ + Bassq = 0267, /* new in v20 */ + + Bconstant = 0300 +}; +typedef enum Opcode Opcode; +typedef unsigned char Opbyte; + + +static void invalid_byte_code_error (char *error_message, ...); + +Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, + CONST Opbyte *program_ptr, + Opcode opcode); + +static Lisp_Object execute_optimized_program (CONST Opbyte *program, + int stack_depth, + Lisp_Object *constants_data); + +extern Lisp_Object Qand_rest, Qand_optional; + +/* Define ERROR_CHECK_BYTE_CODE to enable some minor sanity checking. + Useful for debugging the byte compiler. */ #ifdef DEBUG_XEMACS -#define BYTE_CODE_SAFE +#define ERROR_CHECK_BYTE_CODE #endif + +/* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. + This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */ /* #define BYTE_CODE_METER */ @@ -73,546 +247,644 @@ int byte_metering_on; #define METER_1(code) METER_2 (0, (code)) -#define METER_CODE(last_code, this_code) \ -{ \ - if (byte_metering_on) \ - { \ - if (METER_1 (this_code) != ((1< ival2 ? 1 : 0; + } + + arithcompare_float: + + { + double dval1, dval2; + + if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1); + else if (INTP (obj1)) dval1 = (double) XINT (obj1); + else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1); + else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2); + else if (INTP (obj2)) dval2 = (double) XINT (obj2); + else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2); + else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; + } +#else /* !LISP_FLOAT_TYPE */ + { + int ival1, ival2; + + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; + } +#endif /* !LISP_FLOAT_TYPE */ +} + +static Lisp_Object +bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) +{ +#ifdef LISP_FLOAT_TYPE + int ival1, ival2; + int float_p; + + retry: + + float_p = 0; + + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else if (FLOATP (obj1)) ival1 = 0, float_p = 1; + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else if (FLOATP (obj2)) ival2 = 0, float_p = 1; + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + if (!float_p) + { + switch (opcode) + { + case Bplus: ival1 += ival2; break; + case Bdiff: ival1 -= ival2; break; + case Bmult: ival1 *= ival2; break; + case Bquo: + if (ival2 == 0) Fsignal (Qarith_error, Qnil); + ival1 /= ival2; + break; + case Bmax: if (ival1 < ival2) ival1 = ival2; break; + case Bmin: if (ival1 > ival2) ival1 = ival2; break; + } + return make_int (ival1); + } + else + { + double dval1 = FLOATP (obj1) ? XFLOAT_DATA (obj1) : (double) ival1; + double dval2 = FLOATP (obj2) ? XFLOAT_DATA (obj2) : (double) ival2; + switch (opcode) + { + case Bplus: dval1 += dval2; break; + case Bdiff: dval1 -= dval2; break; + case Bmult: dval1 *= dval2; break; + case Bquo: + if (dval2 == 0) Fsignal (Qarith_error, Qnil); + dval1 /= dval2; + break; + case Bmax: if (dval1 < dval2) dval1 = dval2; break; + case Bmin: if (dval1 > dval2) dval1 = dval2; break; + } + return make_float (dval1); + } +#else /* !LISP_FLOAT_TYPE */ + int ival1, ival2; + + retry: -#define DISCARD(n) (stackp -= (n)) + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + switch (opcode) + { + case Bplus: ival1 += ival2; break; + case Bdiff: ival1 -= ival2; break; + case Bmult: ival1 *= ival2; break; + case Bquo: + if (ival2 == 0) Fsignal (Qarith_error, Qnil); + ival1 /= ival2; + break; + case Bmax: if (ival1 < ival2) ival1 = ival2; break; + case Bmin: if (ival1 > ival2) ival1 = ival2; break; + } + return make_int (ival1); +#endif /* !LISP_FLOAT_TYPE */ +} + +/* Apply compiled-function object FUN to the NARGS evaluated arguments + in ARGS, and return the result of evaluation. */ +Lisp_Object +funcall_compiled_function (Lisp_Object fun, int nargs, Lisp_Object args[]) +{ + /* This function can GC */ + Lisp_Object symbol, tail; + int speccount = specpdl_depth(); + REGISTER int i = 0; + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + int optional = 0; + + if (!OPAQUEP (f->instructions)) + /* Lazily munge the instructions into a more efficient form */ + optimize_compiled_function (fun); + + /* optimize_compiled_function() guaranteed that f->specpdl_depth is + the required space on the specbinding stack for binding the args + and local variables of fun. So just reserve it once. */ + SPECPDL_RESERVE (f->specpdl_depth); + + /* Fmake_byte_code() guaranteed that f->arglist is a valid list + containing only non-constant symbols. */ + LIST_LOOP_3 (symbol, f->arglist, tail) + { + if (EQ (symbol, Qand_rest)) + { + tail = XCDR (tail); + symbol = XCAR (tail); + SPECBIND_FAST_UNSAFE (symbol, Flist (nargs - i, &args[i])); + goto run_code; + } + else if (EQ (symbol, Qand_optional)) + optional = 1; + else if (i == nargs && !optional) + goto wrong_number_of_arguments; + else + SPECBIND_FAST_UNSAFE (symbol, i < nargs ? args[i++] : Qnil); + } + + if (i < nargs) + goto wrong_number_of_arguments; + + run_code: + + { + Lisp_Object value = + execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), + f->stack_depth, + XVECTOR_DATA (f->constants)); + + UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); + return value; + } + + wrong_number_of_arguments: + return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); +} + + +/* Read next uint8 from the instruction stream. */ +#define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++) + +/* Read next uint16 from the instruction stream. */ +#define READ_UINT_2 \ + (program_ptr += 2, \ + (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ + ((unsigned int) (unsigned char) program_ptr[-2]))) + +/* Read next int8 from the instruction stream. */ +#define READ_INT_1 ((int) (signed char) *program_ptr++) + +/* Read next int16 from the instruction stream. */ +#define READ_INT_2 \ + (program_ptr += 2, \ + (((int) ( signed char) program_ptr[-1]) * 256 + \ + ((int) (unsigned char) program_ptr[-2]))) + +/* Read next int8 from instruction stream; don't advance program_pointer */ +#define PEEK_INT_1 ((int) (signed char) program_ptr[0]) + +/* Read next int16 from instruction stream; don't advance program_pointer */ +#define PEEK_INT_2 \ + ((((int) ( signed char) program_ptr[1]) * 256) | \ + ((int) (unsigned char) program_ptr[0])) + +/* Do relative jumps from the current location. + We only do a QUIT if we jump backwards, for efficiency. + No infloops without backward jumps! */ +#define JUMP_RELATIVE(jump) do { \ + int JR_jump = (jump); \ + if (JR_jump < 0) QUIT; \ + program_ptr += JR_jump; \ +} while (0) + +#define JUMP JUMP_RELATIVE (PEEK_INT_2) +#define JUMPR JUMP_RELATIVE (PEEK_INT_1) + +#define JUMP_NEXT ((void) (program_ptr += 2)) +#define JUMPR_NEXT ((void) (program_ptr += 1)) + +/* Push x onto the execution stack. */ +#define PUSH(x) (*++stack_ptr = (x)) + +/* Pop a value off the execution stack. */ +#define POP (*stack_ptr--) + +/* Discard n values from the execution stack. */ +#define DISCARD(n) (stack_ptr -= (n)) /* Get the value which is at the top of the execution stack, but don't pop it. */ +#define TOP (*stack_ptr) -#define TOP (*stackp) +/* The actual interpreter for byte code. + This function has been seriously optimized for performance. + Don't change the constructs unless you are willing to do + real benchmarking and profiling work -- martin */ -DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* -Function used internally in byte-compiled code. -The first argument is a string of byte code; the second, a vector of constants; -the third, the maximum stack depth used in this function. -If the third argument is incorrect, Emacs may crash. -*/ - (bytestr, vector, maxdepth)) + +static Lisp_Object +execute_optimized_program (CONST Opbyte *program, + int stack_depth, + Lisp_Object *constants_data) { /* This function can GC */ - struct gcpro gcpro1, gcpro2, gcpro3; + REGISTER CONST Opbyte *program_ptr = (Opbyte *) program; + REGISTER Lisp_Object *stack_ptr + = alloca_array (Lisp_Object, stack_depth + 1); int speccount = specpdl_depth (); + struct gcpro gcpro1; + #ifdef BYTE_CODE_METER - int this_op = 0; - int prev_op; + Opcode this_opcode = 0; + Opcode prev_opcode; #endif - REGISTER int op; - int pc; - Lisp_Object *stack; - REGISTER Lisp_Object *stackp; - Lisp_Object *stacke; - REGISTER Lisp_Object v1, v2; - REGISTER Lisp_Object *vectorp = XVECTOR_DATA (vector); -#ifdef BYTE_CODE_SAFE - REGISTER int const_length = XVECTOR_LENGTH (vector); + +#ifdef ERROR_CHECK_BYTE_CODE + Lisp_Object *stack_beg = stack_ptr; + Lisp_Object *stack_end = stack_beg + stack_depth; #endif - REGISTER Emchar *massaged_code; - int massaged_code_len; - - CHECK_STRING (bytestr); - if (!VECTORP (vector)) - vector = wrong_type_argument (Qvectorp, vector); - CHECK_NATNUM (maxdepth); - - stackp = alloca_array (Lisp_Object, XINT (maxdepth)); - memset (stackp, 0, XINT (maxdepth) * sizeof (Lisp_Object)); - GCPRO3 (bytestr, vector, *stackp); - gcpro3.nvars = XINT (maxdepth); - - --stackp; - stack = stackp; - stacke = stackp + XINT (maxdepth); - - /* Initialize the pc-register and convert the string into a fixed-width - format for easier processing. */ - massaged_code = alloca_array (Emchar, 1 + XSTRING_CHAR_LENGTH (bytestr)); - massaged_code_len = - convert_bufbyte_string_into_emchar_string (XSTRING_DATA (bytestr), - XSTRING_LENGTH (bytestr), - massaged_code); - massaged_code[massaged_code_len] = 0; - pc = 0; + + /* Initialize all the objects on the stack to Qnil, + so we can GCPRO the whole stack. + The first element of the stack is actually a dummy. */ + { + int i; + Lisp_Object *p; + for (i = stack_depth, p = stack_ptr; i--;) + *++p = Qnil; + } + + GCPRO1 (stack_ptr[1]); + gcpro1.nvars = stack_depth; while (1) { -#ifdef BYTE_CODE_SAFE - if (stackp > stacke) - error ("Byte code stack overflow (byte compiler bug), pc %d, depth %ld", - pc, (long) (stacke - stackp)); - if (stackp < stack) - error ("Byte code stack underflow (byte compiler bug), pc %d", - pc); + REGISTER Opcode opcode = (Opcode) READ_UINT_1; +#ifdef ERROR_CHECK_BYTE_CODE + if (stack_ptr > stack_end) + invalid_byte_code_error ("byte code stack overflow"); + if (stack_ptr < stack_beg) + invalid_byte_code_error ("byte code stack underflow"); #endif #ifdef BYTE_CODE_METER - prev_op = this_op; - this_op = op = FETCH; - METER_CODE (prev_op, op); - switch (op) -#else - switch (op = FETCH) + prev_opcode = this_opcode; + this_opcode = opcode; + METER_CODE (prev_opcode, this_opcode); #endif + + switch (opcode) { - case Bvarref+6: - op = FETCH; - goto varref; - - case Bvarref+7: - op = FETCH2; - goto varref; - - case Bvarref: case Bvarref+1: case Bvarref+2: case Bvarref+3: - case Bvarref+4: case Bvarref+5: - op = op - Bvarref; - varref: - v1 = vectorp[op]; - if (!SYMBOLP (v1)) - v2 = Fsymbol_value (v1); + REGISTER int n; + + default: + if (opcode >= Bconstant) + PUSH (constants_data[opcode - Bconstant]); else - { - v2 = XSYMBOL (v1)->value; - if (SYMBOL_VALUE_MAGIC_P (v2)) - v2 = Fsymbol_value (v1); - } - PUSH (v2); + stack_ptr = execute_rare_opcode (stack_ptr, program_ptr, opcode); + break; + + case Bvarref: + case Bvarref+1: + case Bvarref+2: + case Bvarref+3: + case Bvarref+4: + case Bvarref+5: n = opcode - Bvarref; goto do_varref; + case Bvarref+7: n = READ_UINT_2; goto do_varref; + case Bvarref+6: n = READ_UINT_1; /* most common */ + do_varref: + { + Lisp_Object symbol = constants_data[n]; + Lisp_Object value = XSYMBOL (symbol)->value; + if (SYMBOL_VALUE_MAGIC_P (value)) + value = Fsymbol_value (symbol); + PUSH (value); break; + } - case Bvarset+6: - op = FETCH; - goto varset; - - case Bvarset+7: - op = FETCH2; - goto varset; - - case Bvarset: case Bvarset+1: case Bvarset+2: case Bvarset+3: - case Bvarset+4: case Bvarset+5: - op -= Bvarset; - varset: - Fset (vectorp[op], POP); + case Bvarset: + case Bvarset+1: + case Bvarset+2: + case Bvarset+3: + case Bvarset+4: + case Bvarset+5: n = opcode - Bvarset; goto do_varset; + case Bvarset+7: n = READ_UINT_2; goto do_varset; + case Bvarset+6: n = READ_UINT_1; /* most common */ + do_varset: + { + Lisp_Object symbol = constants_data[n]; + struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); + Lisp_Object old_value = symbol_ptr->value; + Lisp_Object new_value = POP; + if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) + symbol_ptr->value = new_value; + else + Fset (symbol, new_value); break; + } - case Bvarbind+6: - op = FETCH; - goto varbind; - - case Bvarbind+7: - op = FETCH2; - goto varbind; + case Bvarbind: + case Bvarbind+1: + case Bvarbind+2: + case Bvarbind+3: + case Bvarbind+4: + case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind; + case Bvarbind+7: n = READ_UINT_2; goto do_varbind; + case Bvarbind+6: n = READ_UINT_1; /* most common */ + do_varbind: + { + Lisp_Object symbol = constants_data[n]; + struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); + Lisp_Object old_value = symbol_ptr->value; + Lisp_Object new_value = POP; + if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) + { + specpdl_ptr->symbol = symbol; + specpdl_ptr->old_value = old_value; + specpdl_ptr->func = 0; + specpdl_ptr++; + specpdl_depth_counter++; - case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3: - case Bvarbind+4: case Bvarbind+5: - op -= Bvarbind; - varbind: - specbind (vectorp[op], POP); + symbol_ptr->value = new_value; + } + else + specbind_magic (symbol, new_value); break; + } + case Bcall: + case Bcall+1: + case Bcall+2: + case Bcall+3: + case Bcall+4: + case Bcall+5: case Bcall+6: - op = FETCH; - goto docall; - case Bcall+7: - op = FETCH2; - goto docall; - - case Bcall: case Bcall+1: case Bcall+2: case Bcall+3: - case Bcall+4: case Bcall+5: - op -= Bcall; - docall: - DISCARD (op); + n = (opcode < Bcall+6 ? opcode - Bcall : + opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2); + DISCARD (n); #ifdef BYTE_CODE_METER if (byte_metering_on && SYMBOLP (TOP)) { - v1 = TOP; - v2 = Fget (v1, Qbyte_code_meter, Qnil); - if (INTP (v2) - && XINT (v2) != ((1< 0 ? Qt : Qnil; + break; + } case Blss: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_less); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; + break; + } case Bleq: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_less_or_equal); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; + break; + } case Bgeq: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_grtr_or_equal); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; + break; + } - case Bdiff: - DISCARD (1); - TOP = Fminus (2, &TOP); - break; case Bnegate: - v1 = TOP; - if (INTP (v1)) - { - XSETINT (v1, - XINT (v1)); - TOP = v1; - } - else - TOP = Fminus (1, &TOP); + TOP = bytecode_negate (TOP); break; - case Bplus: + case Bnconc: DISCARD (1); - TOP = Fplus (2, &TOP); + TOP = bytecode_nconc2 (&TOP); break; - case Bmax: - DISCARD (1); - TOP = Fmax (2, &TOP); - break; + case Bplus: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = TOP; + TOP = INTP (arg1) && INTP (arg2) ? + make_int (XINT (arg1) + XINT (arg2)) : + bytecode_arithop (arg1, arg2, opcode); + break; + } - case Bmin: - DISCARD (1); - TOP = Fmin (2, &TOP); - break; + case Bdiff: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = TOP; + TOP = INTP (arg1) && INTP (arg2) ? + make_int (XINT (arg1) - XINT (arg2)) : + bytecode_arithop (arg1, arg2, opcode); + break; + } case Bmult: - DISCARD (1); - TOP = Ftimes (2, &TOP); - break; - case Bquo: - DISCARD (1); - TOP = Fquo (2, &TOP); + case Bmax: + case Bmin: + { + Lisp_Object arg = POP; + TOP = bytecode_arithop (TOP, arg, opcode); + break; + } + + case Bpoint: + PUSH (make_int (BUF_PT (current_buffer))); break; - case Brem: - v1 = POP; - TOP = Frem (TOP, v1); + case Binsert: + TOP = Finsert (1, &TOP); break; - case Bpoint: - v1 = make_int (BUF_PT (current_buffer)); - PUSH (v1); + case BinsertN: + n = READ_UINT_1; + DISCARD (n - 1); + TOP = Finsert (n, &TOP); break; + case Baref: + { + Lisp_Object arg = POP; + TOP = Faref (TOP, arg); + break; + } + + case Bmemq: + { + Lisp_Object arg = POP; + TOP = Fmemq (TOP, arg); + break; + } + + + case Bset: + { + Lisp_Object arg = POP; + TOP = Fset (TOP, arg); + break; + } + + case Bequal: + { + Lisp_Object arg = POP; + TOP = Fequal (TOP, arg); + break; + } + + case Bnthcdr: + { + Lisp_Object arg = POP; + TOP = Fnthcdr (TOP, arg); + break; + } + + case Belt: + { + Lisp_Object arg = POP; + TOP = Felt (TOP, arg); + break; + } + + case Bmember: + { + Lisp_Object arg = POP; + TOP = Fmember (TOP, arg); + break; + } + case Bgoto_char: TOP = Fgoto_char (TOP, Qnil); break; - case Binsert: - TOP = Finsert (1, &TOP); - break; + case Bcurrent_buffer: + { + Lisp_Object buffer; + XSETBUFFER (buffer, current_buffer); + PUSH (buffer); + break; + } - case BinsertN: - op = FETCH; - DISCARD (op - 1); - TOP = Finsert (op, &TOP); + case Bset_buffer: + TOP = Fset_buffer (TOP); break; case Bpoint_max: - v1 = make_int (BUF_ZV (current_buffer)); - PUSH (v1); + PUSH (make_int (BUF_ZV (current_buffer))); break; case Bpoint_min: - v1 = make_int (BUF_BEGV (current_buffer)); - PUSH (v1); + PUSH (make_int (BUF_BEGV (current_buffer))); break; - case Bchar_after: - TOP = Fchar_after (TOP, Qnil); - break; + case Bskip_chars_forward: + { + Lisp_Object arg = POP; + TOP = Fskip_chars_forward (TOP, arg, Qnil); + break; + } - case Bfollowing_char: - v1 = Ffollowing_char (Qnil); - PUSH (v1); - break; + case Bassq: + { + Lisp_Object arg = POP; + TOP = Fassq (TOP, arg); + break; + } - case Bpreceding_char: - v1 = Fpreceding_char (Qnil); - PUSH (v1); - break; + case Bsetcar: + { + Lisp_Object arg = POP; + TOP = Fsetcar (TOP, arg); + break; + } - case Bcurrent_column: - v1 = make_int (current_column (current_buffer)); - PUSH (v1); - break; + case Bsetcdr: + { + Lisp_Object arg = POP; + TOP = Fsetcdr (TOP, arg); + break; + } - case Bindent_to: - TOP = Findent_to (TOP, Qnil, Qnil); + case Bnreverse: + TOP = bytecode_nreverse (TOP); break; - case Beolp: - PUSH (Feolp (Qnil)); + case Bcar_safe: + TOP = CONSP (TOP) ? XCAR (TOP) : Qnil; break; - case Beobp: - PUSH (Feobp (Qnil)); + case Bcdr_safe: + TOP = CONSP (TOP) ? XCDR (TOP) : Qnil; break; - case Bbolp: - PUSH (Fbolp (Qnil)); - break; + } + } +} - case Bbobp: - PUSH (Fbobp (Qnil)); - break; +/* It makes a worthwhile performance difference (5%) to shunt + lesser-used opcodes off to a subroutine, to keep the switch in + execute_optimized_program small. If you REALLY care about + performance, you want to keep your heavily executed code away from + rarely executed code, to minimize cache misses. + + Don't make this function static, since then the compiler might inline it. */ +Lisp_Object * +execute_rare_opcode (Lisp_Object *stack_ptr, + CONST Opbyte *program_ptr, + Opcode opcode) +{ + switch (opcode) + { - case Bcurrent_buffer: - PUSH (Fcurrent_buffer ()); - break; + case Bsave_excursion: + record_unwind_protect (save_excursion_restore, + save_excursion_save ()); + break; + + case Bsave_window_excursion: + { + int count = specpdl_depth (); + record_unwind_protect (save_window_excursion_unwind, + Fcurrent_window_configuration (Qnil)); + TOP = Fprogn (TOP); + unbind_to (count, Qnil); + break; + } - case Bset_buffer: - TOP = Fset_buffer (TOP); - break; + case Bsave_restriction: + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); + break; - case Bsave_current_buffer: - record_unwind_protect (save_current_buffer_restore, - Fcurrent_buffer ()); - break; + case Bcatch: + { + Lisp_Object arg = POP; + TOP = internal_catch (TOP, Feval, arg, 0); + break; + } - case Binteractive_p: - PUSH (Finteractive_p ()); - break; + case Bskip_chars_backward: + { + Lisp_Object arg = POP; + TOP = Fskip_chars_backward (TOP, arg, Qnil); + break; + } - case Bforward_char: - TOP = Fforward_char (TOP, Qnil); - break; + case Bunwind_protect: + record_unwind_protect (Fprogn, POP); + break; - case Bforward_word: - TOP = Fforward_word (TOP, Qnil); - break; + case Bcondition_case: + { + Lisp_Object arg2 = POP; /* handlers */ + Lisp_Object arg1 = POP; /* bodyform */ + TOP = condition_case_3 (arg1, TOP, arg2); + break; + } - case Bskip_chars_forward: - v1 = POP; - TOP = Fskip_chars_forward (TOP, v1, Qnil); - break; + case Bset_marker: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = POP; + TOP = Fset_marker (TOP, arg1, arg2); + break; + } - case Bskip_chars_backward: - v1 = POP; - TOP = Fskip_chars_backward (TOP, v1, Qnil); - break; + case Brem: + { + Lisp_Object arg = POP; + TOP = Frem (TOP, arg); + break; + } - case Bforward_line: - TOP = Fforward_line (TOP, Qnil); - break; + case Bmatch_beginning: + TOP = Fmatch_beginning (TOP); + break; - case Bchar_syntax: -#if 0 - CHECK_CHAR_COERCE_INT (TOP); - TOP = make_char (syntax_code_spec - [(int) SYNTAX - (XCHAR_TABLE - (current_buffer->mirror_syntax_table), - XCHAR (TOP))]); -#endif - /*v1 = POP;*/ - TOP = Fchar_syntax(TOP, Qnil); - break; + case Bmatch_end: + TOP = Fmatch_end (TOP); + break; - case Bbuffer_substring: - v1 = POP; - TOP = Fbuffer_substring (TOP, v1, Qnil); - break; + case Bupcase: + TOP = Fupcase (TOP, Qnil); + break; - case Bdelete_region: - v1 = POP; - TOP = Fdelete_region (TOP, v1, Qnil); - break; + case Bdowncase: + TOP = Fdowncase (TOP, Qnil); + break; - case Bnarrow_to_region: - v1 = POP; - TOP = Fnarrow_to_region (TOP, v1, Qnil); - break; + case Bfset: + { + Lisp_Object arg = POP; + TOP = Ffset (TOP, arg); + break; + } - case Bwiden: - PUSH (Fwiden (Qnil)); - break; + case Bstring_equal: + { + Lisp_Object arg = POP; + TOP = Fstring_equal (TOP, arg); + break; + } - case Bend_of_line: - TOP = Fend_of_line (TOP, Qnil); - break; + case Bstring_lessp: + { + Lisp_Object arg = POP; + TOP = Fstring_lessp (TOP, arg); + break; + } - case Bset_marker: - v1 = POP; - v2 = POP; - TOP = Fset_marker (TOP, v2, v1); - break; + case Bsubstring: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = POP; + TOP = Fsubstring (TOP, arg1, arg2); + break; + } - case Bmatch_beginning: - TOP = Fmatch_beginning (TOP); - break; + case Bcurrent_column: + PUSH (make_int (current_column (current_buffer))); + break; - case Bmatch_end: - TOP = Fmatch_end (TOP); - break; + case Bchar_after: + TOP = Fchar_after (TOP, Qnil); + break; - case Bupcase: - TOP = Fupcase (TOP, Qnil); - break; + case Bindent_to: + TOP = Findent_to (TOP, Qnil, Qnil); + break; + + case Bwiden: + PUSH (Fwiden (Qnil)); + break; + + case Bfollowing_char: + PUSH (Ffollowing_char (Qnil)); + break; + + case Bpreceding_char: + PUSH (Fpreceding_char (Qnil)); + break; + + case Beolp: + PUSH (Feolp (Qnil)); + break; + + case Beobp: + PUSH (Feobp (Qnil)); + break; + + case Bbolp: + PUSH (Fbolp (Qnil)); + break; + + case Bbobp: + PUSH (Fbobp (Qnil)); + break; - case Bdowncase: - TOP = Fdowncase (TOP, Qnil); + case Bsave_current_buffer: + record_unwind_protect (save_current_buffer_restore, + Fcurrent_buffer ()); + break; + + case Binteractive_p: + PUSH (Finteractive_p ()); + break; + + case Bforward_char: + TOP = Fforward_char (TOP, Qnil); + break; + + case Bforward_word: + TOP = Fforward_word (TOP, Qnil); + break; + + case Bforward_line: + TOP = Fforward_line (TOP, Qnil); + break; + + case Bchar_syntax: + TOP = Fchar_syntax (TOP, Qnil); + break; + + case Bbuffer_substring: + { + Lisp_Object arg = POP; + TOP = Fbuffer_substring (TOP, arg, Qnil); + break; + } + + case Bdelete_region: + { + Lisp_Object arg = POP; + TOP = Fdelete_region (TOP, arg, Qnil); + break; + } + + case Bnarrow_to_region: + { + Lisp_Object arg = POP; + TOP = Fnarrow_to_region (TOP, arg, Qnil); + break; + } + + case Bend_of_line: + TOP = Fend_of_line (TOP, Qnil); + break; + + case Btemp_output_buffer_setup: + temp_output_buffer_setup (TOP); + TOP = Vstandard_output; + break; + + case Btemp_output_buffer_show: + { + Lisp_Object arg = POP; + temp_output_buffer_show (TOP, Qnil); + TOP = arg; + /* GAG ME!! */ + /* pop binding of standard-output */ + unbind_to (specpdl_depth() - 1, Qnil); break; + } + + case Bold_eq: + { + Lisp_Object arg = POP; + TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; + break; + } + + case Bold_memq: + { + Lisp_Object arg = POP; + TOP = Fold_memq (TOP, arg); + break; + } + + case Bold_equal: + { + Lisp_Object arg = POP; + TOP = Fold_equal (TOP, arg); + break; + } + + case Bold_member: + { + Lisp_Object arg = POP; + TOP = Fold_member (TOP, arg); + break; + } + + case Bold_assq: + { + Lisp_Object arg = POP; + TOP = Fold_assq (TOP, arg); + break; + } + + default: + abort(); + break; + } + return stack_ptr; +} + + +static void +invalid_byte_code_error (char *error_message, ...) +{ + Lisp_Object obj; + va_list args; + char *buf = alloca_array (char, strlen (error_message) + 128); + + sprintf (buf, "%s", error_message); + va_start (args, error_message); + obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1, + args); + va_end (args); + + signal_error (Qinvalid_byte_code, list1 (obj)); +} + +/* Check for valid opcodes. Change this when adding new opcodes. */ +static void +check_opcode (Opcode opcode) +{ + if ((opcode < Bvarref) || + (opcode == 0251) || + (opcode > Bassq && opcode < Bconstant)) + invalid_byte_code_error + ("invalid opcode %d in instruction stream", opcode); +} - case Bstringeqlsign: - v1 = POP; - TOP = Fstring_equal (TOP, v1); +/* Check that IDX is a valid offset into the `constants' vector */ +static void +check_constants_index (int idx, Lisp_Object constants) +{ + if (idx < 0 || idx >= XVECTOR_LENGTH (constants)) + invalid_byte_code_error + ("reference %d to constants array out of range 0, %d", + idx, XVECTOR_LENGTH (constants) - 1); +} + +/* Get next character from Lisp instructions string. */ +#define READ_INSTRUCTION_CHAR(lvalue) do { \ + (lvalue) = charptr_emchar (ptr); \ + INC_CHARPTR (ptr); \ + *icounts_ptr++ = program_ptr - program; \ + if (lvalue > UCHAR_MAX) \ + invalid_byte_code_error \ + ("Invalid character %c in byte code string"); \ +} while (0) + +/* Get opcode from Lisp instructions string. */ +#define READ_OPCODE do { \ + unsigned int c; \ + READ_INSTRUCTION_CHAR (c); \ + opcode = (Opcode) c; \ +} while (0) + +/* Get next operand, a uint8, from Lisp instructions string. */ +#define READ_OPERAND_1 do { \ + READ_INSTRUCTION_CHAR (arg); \ + argsize = 1; \ +} while (0) + +/* Get next operand, a uint16, from Lisp instructions string. */ +#define READ_OPERAND_2 do { \ + unsigned int arg1, arg2; \ + READ_INSTRUCTION_CHAR (arg1); \ + READ_INSTRUCTION_CHAR (arg2); \ + arg = arg1 + (arg2 << 8); \ + argsize = 2; \ +} while (0) + +/* Write 1 byte to PTR, incrementing PTR */ +#define WRITE_INT8(value, ptr) do { \ + *((ptr)++) = (value); \ +} while (0) + +/* Write 2 bytes to PTR, incrementing PTR */ +#define WRITE_INT16(value, ptr) do { \ + WRITE_INT8 (((unsigned) (value)) & 0x00ff, (ptr)); \ + WRITE_INT8 (((unsigned) (value)) >> 8 , (ptr)); \ +} while (0) + +/* We've changed our minds about the opcode we've already written. */ +#define REWRITE_OPCODE(new_opcode) ((void) (program_ptr[-1] = new_opcode)) + +/* Encode an op arg within the opcode, or as a 1 or 2-byte operand. */ +#define WRITE_NARGS(base_opcode) do { \ + if (arg <= 5) \ + { \ + REWRITE_OPCODE (base_opcode + arg); \ + } \ + else if (arg <= UCHAR_MAX) \ + { \ + REWRITE_OPCODE (base_opcode + 6); \ + WRITE_INT8 (arg, program_ptr); \ + } \ + else \ + { \ + REWRITE_OPCODE (base_opcode + 7); \ + WRITE_INT16 (arg, program_ptr); \ + } \ +} while (0) + +/* Encode a constants reference within the opcode, or as a 2-byte operand. */ +#define WRITE_CONSTANT do { \ + check_constants_index(arg, constants); \ + if (arg <= UCHAR_MAX - Bconstant) \ + { \ + REWRITE_OPCODE (Bconstant + arg); \ + } \ + else \ + { \ + REWRITE_OPCODE (Bconstant2); \ + WRITE_INT16 (arg, program_ptr); \ + } \ +} while (0) + +#define WRITE_OPCODE WRITE_INT8 (opcode, program_ptr) + +/* Compile byte code instructions into free space provided by caller, with + size >= (2 * string_char_length (instructions) + 1) * sizeof (Opbyte). + Returns length of compiled code. */ +static void +optimize_byte_code (/* in */ + Lisp_Object instructions, + Lisp_Object constants, + /* out */ + Opbyte * CONST program, + int * CONST program_length, + int * CONST varbind_count) +{ + size_t instructions_length = XSTRING_LENGTH (instructions); + size_t comfy_size = 2 * instructions_length; + + int * CONST icounts = alloca_array (int, comfy_size); + int * icounts_ptr = icounts; + + /* We maintain a table of jumps in the source code. */ + struct jump + { + int from; + int to; + }; + struct jump * CONST jumps = alloca_array (struct jump, comfy_size); + struct jump *jumps_ptr = jumps; + + Opbyte *program_ptr = program; + + CONST Bufbyte *ptr = XSTRING_DATA (instructions); + CONST Bufbyte * CONST end = ptr + instructions_length; + + *varbind_count = 0; + + while (ptr < end) + { + Opcode opcode; + int arg; + int argsize = 0; + READ_OPCODE; + WRITE_OPCODE; + + switch (opcode) + { + Lisp_Object val; + + case Bvarref+7: READ_OPERAND_2; goto do_varref; + case Bvarref+6: READ_OPERAND_1; goto do_varref; + case Bvarref: case Bvarref+1: case Bvarref+2: + case Bvarref+3: case Bvarref+4: case Bvarref+5: + arg = opcode - Bvarref; + do_varref: + check_constants_index (arg, constants); + val = XVECTOR_DATA (constants) [arg]; + if (!SYMBOLP (val)) + invalid_byte_code_error ("variable reference to non-symbol %S", val); + if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) + invalid_byte_code_error ("variable reference to constant symbol %s", + string_data (XSYMBOL (val)->name)); + WRITE_NARGS (Bvarref); + break; + + case Bvarset+7: READ_OPERAND_2; goto do_varset; + case Bvarset+6: READ_OPERAND_1; goto do_varset; + case Bvarset: case Bvarset+1: case Bvarset+2: + case Bvarset+3: case Bvarset+4: case Bvarset+5: + arg = opcode - Bvarset; + do_varset: + check_constants_index (arg, constants); + val = XVECTOR_DATA (constants) [arg]; + if (!SYMBOLP (val)) + invalid_byte_code_error ("attempt to set non-symbol %S", val); + if (EQ (val, Qnil) || EQ (val, Qt)) + invalid_byte_code_error ("attempt to set constant symbol %s", + string_data (XSYMBOL (val)->name)); + /* Ignore assignments to keywords by converting to Bdiscard. + For backward compatibility only - we'd like to make this an error. */ + if (SYMBOL_IS_KEYWORD (val)) + REWRITE_OPCODE (Bdiscard); + else + WRITE_NARGS (Bvarset); + break; + + case Bvarbind+7: READ_OPERAND_2; goto do_varbind; + case Bvarbind+6: READ_OPERAND_1; goto do_varbind; + case Bvarbind: case Bvarbind+1: case Bvarbind+2: + case Bvarbind+3: case Bvarbind+4: case Bvarbind+5: + arg = opcode - Bvarbind; + do_varbind: + (*varbind_count)++; + check_constants_index (arg, constants); + val = XVECTOR_DATA (constants) [arg]; + if (!SYMBOLP (val)) + invalid_byte_code_error ("attempt to let-bind non-symbol %S", val); + if (EQ (val, Qnil) || EQ (val, Qt) || (SYMBOL_IS_KEYWORD (val))) + invalid_byte_code_error ("attempt to let-bind constant symbol %s", + string_data (XSYMBOL (val)->name)); + WRITE_NARGS (Bvarbind); + break; + + case Bcall+7: READ_OPERAND_2; goto do_call; + case Bcall+6: READ_OPERAND_1; goto do_call; + case Bcall: case Bcall+1: case Bcall+2: + case Bcall+3: case Bcall+4: case Bcall+5: + arg = opcode - Bcall; + do_call: + WRITE_NARGS (Bcall); + break; + + case Bunbind+7: READ_OPERAND_2; goto do_unbind; + case Bunbind+6: READ_OPERAND_1; goto do_unbind; + case Bunbind: case Bunbind+1: case Bunbind+2: + case Bunbind+3: case Bunbind+4: case Bunbind+5: + arg = opcode - Bunbind; + do_unbind: + WRITE_NARGS (Bunbind); break; - case Bstringlss: - v1 = POP; - TOP = Fstring_lessp (TOP, v1); + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + READ_OPERAND_2; + /* Make program_ptr-relative */ + arg += icounts - (icounts_ptr - argsize); + goto do_jump; + + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + READ_OPERAND_1; + /* Make program_ptr-relative */ + arg -= 127; + do_jump: + /* Record program-relative goto addresses in `jumps' table */ + jumps_ptr->from = icounts_ptr - icounts - argsize; + jumps_ptr->to = jumps_ptr->from + arg; + jumps_ptr++; + if (arg >= -1 && arg <= argsize) + invalid_byte_code_error + ("goto instruction is its own target"); + if (arg <= SCHAR_MIN || + arg > SCHAR_MAX) + { + if (argsize == 1) + REWRITE_OPCODE (opcode + Bgoto - BRgoto); + WRITE_INT16 (arg, program_ptr); + } + else + { + if (argsize == 2) + REWRITE_OPCODE (opcode + BRgoto - Bgoto); + WRITE_INT8 (arg, program_ptr); + } break; - case Bequal: - v1 = POP; - TOP = Fequal (TOP, v1); + case Bconstant2: + READ_OPERAND_2; + WRITE_CONSTANT; break; - case Bold_equal: - v1 = POP; - TOP = Fold_equal (TOP, v1); + case BlistN: + case BconcatN: + case BinsertN: + READ_OPERAND_1; + WRITE_INT8 (arg, program_ptr); break; - case Bnthcdr: - v1 = POP; - v2 = TOP; - CHECK_NATNUM (v2); - for (op = XINT (v2); op; op--) + default: + if (opcode < Bconstant) + check_opcode (opcode); + else { - if (CONSP (v1)) - v1 = XCDR (v1); - else if (NILP (v1)) - break; - else - { - v1 = wrong_type_argument (Qlistp, v1); - op++; - } + arg = opcode - Bconstant; + WRITE_CONSTANT; } - TOP = v1; break; + } + } - case Belt: -#if 0 - /* probably this code is OK, but nth_entry is commented - out above --ben */ - /* #### will not work if cons type is an lrecord. */ - if (XTYPE (TOP) == Lisp_Type_Cons) + /* Fix up jumps table to refer to NEW offsets. */ + { + struct jump *j; + for (j = jumps; j < jumps_ptr; j++) + { +#ifdef ERROR_CHECK_BYTE_CODE + assert (j->from < icounts_ptr - icounts); + assert (j->to < icounts_ptr - icounts); +#endif + j->from = icounts[j->from]; + j->to = icounts[j->to]; +#ifdef ERROR_CHECK_BYTE_CODE + assert (j->from < program_ptr - program); + assert (j->to < program_ptr - program); + check_opcode ((Opcode) (program[j->from-1])); +#endif + check_opcode ((Opcode) (program[j->to])); + } + } + + /* Fixup jumps in byte-code until no more fixups needed */ + { + int more_fixups_needed = 1; + + while (more_fixups_needed) + { + struct jump *j; + more_fixups_needed = 0; + for (j = jumps; j < jumps_ptr; j++) + { + int from = j->from; + int to = j->to; + int jump = to - from; + Opbyte *p = program + from; + Opcode opcode = (Opcode) p[-1]; + if (!more_fixups_needed) + check_opcode ((Opcode) p[jump]); + assert (to >= 0 && program + to < program_ptr); + switch (opcode) { - /* Exchange args and then do nth. */ - v2 = POP; - v1 = TOP; - goto nth_entry; + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + WRITE_INT16 (jump, p); + break; + + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + if (jump > SCHAR_MIN && + jump <= SCHAR_MAX) + { + WRITE_INT8 (jump, p); + } + else /* barf */ + { + struct jump *jj; + for (jj = jumps; jj < jumps_ptr; jj++) + { + assert (jj->from < program_ptr - program); + assert (jj->to < program_ptr - program); + if (jj->from > from) jj->from++; + if (jj->to > from) jj->to++; + } + p[-1] += Bgoto - BRgoto; + more_fixups_needed = 1; + memmove (p+1, p, program_ptr++ - p); + WRITE_INT16 (jump, p); + } + break; + + default: + abort(); + break; } + } + } + } + + /* *program_ptr++ = 0; */ + *program_length = program_ptr - program; +} + +/* Optimize the byte code and store the optimized program, only + understood by bytecode.c, in an opaque object in the + instructions slot of the Compiled_Function object. */ +void +optimize_compiled_function (Lisp_Object compiled_function) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); + int program_length; + int varbind_count; + Opbyte *program; + + /* If we have not actually read the bytecode string + and constants vector yet, fetch them from the file. */ + if (CONSP (f->instructions)) + Ffetch_bytecode (compiled_function); + + if (STRINGP (f->instructions)) + { + /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(), + which would be slightly more `proper' */ + program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); + optimize_byte_code (f->instructions, f->constants, + program, &program_length, &varbind_count); + f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count; + f->instructions = + Fpurecopy (make_opaque (program_length * sizeof (Opbyte), + (CONST void *) program)); + } + + assert (OPAQUEP (f->instructions)); +} + +/************************************************************************/ +/* The compiled-function object type */ +/************************************************************************/ +static void +print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, + int escapeflag) +{ + /* This function can GC */ + Lisp_Compiled_Function *f = + XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ + int docp = f->flags.documentationp; + int intp = f->flags.interactivep; + struct gcpro gcpro1, gcpro2; + char buf[100]; + GCPRO2 (obj, printcharfun); + + write_c_string (print_readably ? "#[" : "#", printcharfun); +} + + +static Lisp_Object +mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); + + markobj (f->instructions); + markobj (f->arglist); + markobj (f->doc_and_interactive); +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + markobj (f->annotated); #endif - v1 = POP; - TOP = Felt (TOP, v1); - break; + /* tail-recurse on constants */ + return f->constants; +} - case Bmember: - v1 = POP; - TOP = Fmember (TOP, v1); - break; +static int +compiled_function_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + Lisp_Compiled_Function *f1 = XCOMPILED_FUNCTION (obj1); + Lisp_Compiled_Function *f2 = XCOMPILED_FUNCTION (obj2); + return + (f1->flags.documentationp == f2->flags.documentationp && + f1->flags.interactivep == f2->flags.interactivep && + f1->flags.domainp == f2->flags.domainp && /* I18N3 */ + internal_equal (compiled_function_instructions (f1), + compiled_function_instructions (f2), depth + 1) && + internal_equal (f1->constants, f2->constants, depth + 1) && + internal_equal (f1->arglist, f2->arglist, depth + 1) && + internal_equal (f1->doc_and_interactive, + f2->doc_and_interactive, depth + 1)); +} - case Bold_member: - v1 = POP; - TOP = Fold_member (TOP, v1); - break; +static unsigned long +compiled_function_hash (Lisp_Object obj, int depth) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); + return HASH3 ((f->flags.documentationp << 2) + + (f->flags.interactivep << 1) + + f->flags.domainp, + internal_hash (f->instructions, depth + 1), + internal_hash (f->constants, depth + 1)); +} - case Bassq: - v1 = POP; - TOP = Fassq (TOP, v1); - break; +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, + mark_compiled_function, + print_compiled_function, 0, + compiled_function_equal, + compiled_function_hash, + Lisp_Compiled_Function); + +DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* +Return t if OBJECT is a byte-compiled function object. +*/ + (object)) +{ + return COMPILED_FUNCTIONP (object) ? Qt : Qnil; +} - case Bold_assq: - v1 = POP; - TOP = Fold_assq (TOP, v1); - break; +/************************************************************************/ +/* compiled-function object accessor functions */ +/************************************************************************/ - case Bnreverse: - TOP = Fnreverse (TOP); - break; +Lisp_Object +compiled_function_arglist (Lisp_Compiled_Function *f) +{ + return f->arglist; +} - case Bsetcar: - v1 = POP; - TOP = Fsetcar (TOP, v1); - break; +Lisp_Object +compiled_function_instructions (Lisp_Compiled_Function *f) +{ + if (! OPAQUEP (f->instructions)) + return f->instructions; - case Bsetcdr: - v1 = POP; - TOP = Fsetcdr (TOP, v1); - break; + { + /* Invert action performed by optimize_byte_code() */ + Lisp_Opaque *opaque = XOPAQUE (f->instructions); + + Bufbyte * CONST buffer = + alloca_array (Bufbyte, OPAQUE_SIZE (opaque) * MAX_EMCHAR_LEN); + Bufbyte *bp = buffer; + + CONST Opbyte * CONST program = (CONST Opbyte *) OPAQUE_DATA (opaque); + CONST Opbyte *program_ptr = program; + CONST Opbyte * CONST program_end = program_ptr + OPAQUE_SIZE (opaque); + + while (program_ptr < program_end) + { + Opcode opcode = (Opcode) READ_UINT_1; + bp += set_charptr_emchar (bp, opcode); + switch (opcode) + { + case Bvarref+7: + case Bvarset+7: + case Bvarbind+7: + case Bcall+7: + case Bunbind+7: + case Bconstant2: + bp += set_charptr_emchar (bp, READ_UINT_1); + bp += set_charptr_emchar (bp, READ_UINT_1); + break; + + case Bvarref+6: + case Bvarset+6: + case Bvarbind+6: + case Bcall+6: + case Bunbind+6: + case BlistN: + case BconcatN: + case BinsertN: + bp += set_charptr_emchar (bp, READ_UINT_1); + break; + + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + { + int jump = READ_INT_2; + Opbyte buf2[2]; + Opbyte *buf2p = buf2; + /* Convert back to program-relative address */ + WRITE_INT16 (jump + (program_ptr - 2 - program), buf2p); + bp += set_charptr_emchar (bp, buf2[0]); + bp += set_charptr_emchar (bp, buf2[1]); + break; + } - case Bcar_safe: - v1 = TOP; - if (CONSP (v1)) - TOP = XCAR (v1); - else - TOP = Qnil; - break; + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + bp += set_charptr_emchar (bp, READ_INT_1 + 127); + break; + + default: + break; + } + } + return make_string (buffer, bp - buffer); + } +} - case Bcdr_safe: - v1 = TOP; - if (CONSP (v1)) - TOP = XCDR (v1); - else - TOP = Qnil; - break; +Lisp_Object +compiled_function_constants (Lisp_Compiled_Function *f) +{ + return f->constants; +} - case Bnconc: - DISCARD (1); - TOP = Fnconc (2, &TOP); - break; +int +compiled_function_stack_depth (Lisp_Compiled_Function *f) +{ + return f->stack_depth; +} - case Bnumberp: - TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; - break; +/* The compiled_function->doc_and_interactive slot uses the minimal + number of conses, based on compiled_function->flags; it may take + any of the following forms: + + doc + interactive + domain + (doc . interactive) + (doc . domain) + (interactive . domain) + (doc . (interactive . domain)) + */ - case Bintegerp: - TOP = INTP (TOP) ? Qt : Qnil; - break; +/* Caller must check flags.interactivep first */ +Lisp_Object +compiled_function_interactive (Lisp_Compiled_Function *f) +{ + assert (f->flags.interactivep); + if (f->flags.documentationp && f->flags.domainp) + return XCAR (XCDR (f->doc_and_interactive)); + else if (f->flags.documentationp) + return XCDR (f->doc_and_interactive); + else if (f->flags.domainp) + return XCAR (f->doc_and_interactive); + else + return f->doc_and_interactive; +} + +/* Caller need not check flags.documentationp first */ +Lisp_Object +compiled_function_documentation (Lisp_Compiled_Function *f) +{ + if (! f->flags.documentationp) + return Qnil; + else if (f->flags.interactivep && f->flags.domainp) + return XCAR (f->doc_and_interactive); + else if (f->flags.interactivep) + return XCAR (f->doc_and_interactive); + else if (f->flags.domainp) + return XCAR (f->doc_and_interactive); + else + return f->doc_and_interactive; +} + +/* Caller need not check flags.domainp first */ +Lisp_Object +compiled_function_domain (Lisp_Compiled_Function *f) +{ + if (! f->flags.domainp) + return Qnil; + else if (f->flags.documentationp && f->flags.interactivep) + return XCDR (XCDR (f->doc_and_interactive)); + else if (f->flags.documentationp) + return XCDR (f->doc_and_interactive); + else if (f->flags.interactivep) + return XCDR (f->doc_and_interactive); + else + return f->doc_and_interactive; +} + +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + +Lisp_Object +compiled_function_annotation (Lisp_Compiled_Function *f) +{ + return f->annotated; +} - default: -#ifdef BYTE_CODE_SAFE - if (op < Bconstant) - error ("unknown bytecode %d (byte compiler bug)", op); - if ((op -= Bconstant) >= const_length) - error ("no constant number %d (byte compiler bug)", op); - PUSH (vectorp[op]); -#else - PUSH (vectorp[op - Bconstant]); #endif - } + +/* used only by Snarf-documentation; there must be doc already. */ +void +set_compiled_function_documentation (Lisp_Compiled_Function *f, + Lisp_Object new_doc) +{ + assert (f->flags.documentationp); + assert (INTP (new_doc) || STRINGP (new_doc)); + + if (f->flags.interactivep && f->flags.domainp) + XCAR (f->doc_and_interactive) = new_doc; + else if (f->flags.interactivep) + XCAR (f->doc_and_interactive) = new_doc; + else if (f->flags.domainp) + XCAR (f->doc_and_interactive) = new_doc; + else + f->doc_and_interactive = new_doc; +} + + +DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* +Return the argument list of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_arglist (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* +Return the byte-opcode string of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_instructions (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* +Return the constants vector of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_constants (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* +Return the max stack depth of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function))); +} + +DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* +Return the doc string of the compiled-function object FUNCTION, if available. +Functions that had their doc strings snarfed into the DOC file will have +an integer returned instead of a string. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_documentation (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* +Return the interactive spec of the compiled-function object FUNCTION, or nil. +If non-nil, the return value will be a list whose first element is +`interactive' and whose second element is the interactive spec. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return XCOMPILED_FUNCTION (function)->flags.interactivep + ? list2 (Qinteractive, + compiled_function_interactive (XCOMPILED_FUNCTION (function))) + : Qnil; +} + +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + +/* Remove the `xx' if you wish to restore this feature */ +xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* +Return the annotation of the compiled-function object FUNCTION, or nil. +The annotation is a piece of information indicating where this +compiled-function object came from. Generally this will be +a symbol naming a function; or a string naming a file, if the +compiled-function object was not defined in a function; or nil, +if the compiled-function object was not created as a result of +a `load'. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_annotation (XCOMPILED_FUNCTION (function)); +} + +#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ + +DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* +Return the domain of the compiled-function object FUNCTION, or nil. +This is only meaningful if I18N3 was enabled when emacs was compiled. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return XCOMPILED_FUNCTION (function)->flags.domainp + ? compiled_function_domain (XCOMPILED_FUNCTION (function)) + : Qnil; +} + + + +DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* +If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now. +*/ + (function)) +{ + Lisp_Compiled_Function *f; + CHECK_COMPILED_FUNCTION (function); + f = XCOMPILED_FUNCTION (function); + + if (OPAQUEP (f->instructions) || STRINGP (f->instructions)) + return function; + + if (CONSP (XCOMPILED_FUNCTION (function)->instructions)) + { + Lisp_Object tem = read_doc_string (f->instructions); + if (!CONSP (tem)) + signal_simple_error ("Invalid lazy-loaded byte code", tem); + /* v18 or v19 bytecode file. Need to Ebolify. */ + if (f->flags.ebolified && VECTORP (XCDR (tem))) + ebolify_bytecode_constants (XCDR (tem)); + /* VERY IMPORTANT to purecopy here!!!!! + See load_force_doc_string_unwind. */ + /* f->instructions = Fpurecopy (XCAR (tem)); */ + f->constants = Fpurecopy (XCDR (tem)); + return function; } + abort (); + return Qnil; /* not reached */ +} - exit: - UNGCPRO; - /* Binds and unbinds are supposed to be compiled balanced. */ - if (specpdl_depth() != speccount) - /* FSF: abort() if BYTE_CODE_SAFE not defined */ - error ("binding stack not balanced (serious byte compiler bug)"); - return v1; +DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /* +Convert compiled function FUNCTION into an optimized internal form. +*/ + (function)) +{ + Lisp_Compiled_Function *f; + CHECK_COMPILED_FUNCTION (function); + f = XCOMPILED_FUNCTION (function); + + if (OPAQUEP (f->instructions)) /* Already optimized? */ + return Qnil; + + optimize_compiled_function (function); + return Qnil; +} + +DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* +Function used internally in byte-compiled code. +First argument INSTRUCTIONS is a string of byte code. +Second argument CONSTANTS is a vector of constants. +Third argument STACK-DEPTH is the maximum stack depth used in this function. +If STACK-DEPTH is incorrect, Emacs may crash. +*/ + (instructions, constants, stack_depth)) +{ + /* This function can GC */ + int varbind_count; + int program_length; + Opbyte *program; + + CHECK_STRING (instructions); + CHECK_VECTOR (constants); + CHECK_NATNUM (stack_depth); + + /* Optimize the `instructions' string, just like when executing a + regular compiled function, but don't save it for later since this is + likely to only be executed once. */ + program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); + optimize_byte_code (instructions, constants, program, + &program_length, &varbind_count); + SPECPDL_RESERVE (varbind_count); + return execute_optimized_program (program, + XINT (stack_depth), + XVECTOR_DATA (constants)); } + void syms_of_bytecode (void) { + deferror (&Qinvalid_byte_code, "invalid-byte-code", + "Invalid byte code", Qerror); defsymbol (&Qbyte_code, "byte-code"); + defsymbol (&Qcompiled_functionp, "compiled-function-p"); + DEFSUBR (Fbyte_code); + DEFSUBR (Ffetch_bytecode); + DEFSUBR (Foptimize_compiled_function); + + DEFSUBR (Fcompiled_function_p); + DEFSUBR (Fcompiled_function_instructions); + DEFSUBR (Fcompiled_function_constants); + DEFSUBR (Fcompiled_function_stack_depth); + DEFSUBR (Fcompiled_function_arglist); + DEFSUBR (Fcompiled_function_interactive); + DEFSUBR (Fcompiled_function_doc_string); + DEFSUBR (Fcompiled_function_domain); +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + DEFSUBR (Fcompiled_function_annotation); +#endif + #ifdef BYTE_CODE_METER defsymbol (&Qbyte_code_meter, "byte-code-meter"); #endif @@ -1197,7 +2436,7 @@ vars_of_bytecode (void) #ifdef BYTE_CODE_METER DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* -A vector of vectors which holds a histogram of byte-code usage. +A vector of vectors which holds a histogram of byte code usage. \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte opcode CODE has been executed. \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, @@ -1206,7 +2445,7 @@ executed in succession. */ ); DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /* If non-nil, keep profiling information on byte code usage. -The variable byte-code-meter indicates how often each byte opcode is used. +The variable `byte-code-meter' indicates how often each byte opcode is used. If a symbol has a property named `byte-code-meter' whose value is an integer, it is incremented each time that symbol's function is called. */ ); @@ -1216,8 +2455,7 @@ integer, it is incremented each time that symbol's function is called. { int i = 256; while (i--) - XVECTOR_DATA (Vbyte_code_meter)[i] = - make_vector (256, Qzero); + XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); } -#endif +#endif /* BYTE_CODE_METER */ } diff --git a/src/bytecode.h b/src/bytecode.h index f9294d2..3387b93 100644 --- a/src/bytecode.h +++ b/src/bytecode.h @@ -30,14 +30,15 @@ Boston, MA 02111-1307, USA. */ #ifndef _XEMACS_BYTECODE_H_ #define _XEMACS_BYTECODE_H_ -/* Meanings of slots in a Lisp_Compiled_Function. */ -#define COMPILED_ARGLIST 0 -#define COMPILED_BYTECODE 1 -#define COMPILED_CONSTANTS 2 -#define COMPILED_STACK_DEPTH 3 -#define COMPILED_DOC_STRING 4 -#define COMPILED_INTERACTIVE 5 -#define COMPILED_DOMAIN 6 +/* Meanings of slots in a Lisp_Compiled_Function. + Don't use these! For backward compatibility only. */ +#define COMPILED_ARGLIST 0 +#define COMPILED_INSTRUCTIONS 1 +#define COMPILED_CONSTANTS 2 +#define COMPILED_STACK_DEPTH 3 +#define COMPILED_DOC_STRING 4 +#define COMPILED_INTERACTIVE 5 +#define COMPILED_DOMAIN 6 /* It doesn't make sense to have this and also have load-history */ /* #define COMPILED_FUNCTION_ANNOTATION_HACK */ @@ -45,7 +46,8 @@ Boston, MA 02111-1307, USA. */ struct Lisp_Compiled_Function { struct lrecord_header lheader; - unsigned short maxdepth; + unsigned short stack_depth; + unsigned short specpdl_depth; struct { unsigned int documentationp: 1; @@ -56,7 +58,7 @@ struct Lisp_Compiled_Function We need to Ebolify the `assoc', `delq', etc. functions. */ unsigned int ebolified: 1; } flags; - Lisp_Object bytecodes; + Lisp_Object instructions; Lisp_Object constants; Lisp_Object arglist; /* This uses the minimal number of conses; see accessors in data.c. */ @@ -66,25 +68,35 @@ struct Lisp_Compiled_Function Lisp_Object annotated; #endif }; +typedef struct Lisp_Compiled_Function Lisp_Compiled_Function; -Lisp_Object compiled_function_documentation (struct Lisp_Compiled_Function *b); -Lisp_Object compiled_function_interactive (struct Lisp_Compiled_Function *b); -Lisp_Object compiled_function_domain (struct Lisp_Compiled_Function *b); -void set_compiled_function_documentation (struct Lisp_Compiled_Function *b, - Lisp_Object); -Lisp_Object compiled_function_annotation (struct Lisp_Compiled_Function *b); +Lisp_Object run_byte_code (Lisp_Object compiled_function_or_instructions, ...); -DECLARE_LRECORD (compiled_function, struct Lisp_Compiled_Function); +Lisp_Object compiled_function_arglist (Lisp_Compiled_Function *f); +Lisp_Object compiled_function_instructions (Lisp_Compiled_Function *f); +Lisp_Object compiled_function_constants (Lisp_Compiled_Function *f); +int compiled_function_stack_depth (Lisp_Compiled_Function *f); +Lisp_Object compiled_function_documentation (Lisp_Compiled_Function *f); +Lisp_Object compiled_function_annotation (Lisp_Compiled_Function *f); +Lisp_Object compiled_function_domain (Lisp_Compiled_Function *f); +Lisp_Object compiled_function_interactive (Lisp_Compiled_Function *f); + +void set_compiled_function_documentation (Lisp_Compiled_Function *f, + Lisp_Object new_doc); + +Lisp_Object funcall_compiled_function (Lisp_Object fun, + int nargs, Lisp_Object args[]); +void optimize_compiled_function (Lisp_Object compiled_function); + +DECLARE_LRECORD (compiled_function, Lisp_Compiled_Function); #define XCOMPILED_FUNCTION(x) XRECORD (x, compiled_function, \ - struct Lisp_Compiled_Function) + Lisp_Compiled_Function) #define XSETCOMPILED_FUNCTION(x, p) XSETRECORD (x, p, compiled_function) #define COMPILED_FUNCTIONP(x) RECORDP (x, compiled_function) #define GC_COMPILED_FUNCTIONP(x) GC_RECORDP (x, compiled_function) #define CHECK_COMPILED_FUNCTION(x) CHECK_RECORD (x, compiled_function) #define CONCHECK_COMPILED_FUNCTION(x) CONCHECK_RECORD (x, compiled_function) -EXFUN (Fbyte_code, 3); - extern Lisp_Object Qbyte_code; /* total 1765 internal 101 doc-and-int 775 doc-only 389 int-only 42 neither 559 diff --git a/src/callint.c b/src/callint.c index dac2dfb..14d9e23 100644 --- a/src/callint.c +++ b/src/callint.c @@ -294,10 +294,10 @@ when reading the arguments. } else if (COMPILED_FUNCTIONP (fun)) { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - if (!(b->flags.interactivep)) + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + if (! f->flags.interactivep) goto lose; - specs = compiled_function_interactive (b); + specs = compiled_function_interactive (f); } else if (!CONSP (fun)) goto lose; @@ -405,7 +405,7 @@ when reading the arguments. { Lisp_Object domain = Qnil; if (COMPILED_FUNCTIONP (fun)) - domain = Fcompiled_function_domain (fun); + domain = compiled_function_domain (XCOMPILED_FUNCTION (fun)); if (NILP (domain)) specs = Fgettext (specs); else @@ -525,7 +525,7 @@ when reading the arguments. struct gcpro gcpro1; GCPRO1 (fun); - fun = funcall_recording_as (function, 1, &fun); + fun = Ffuncall (1, &fun); UNGCPRO; } if (set_zmacs_region_stays) diff --git a/src/callproc.c b/src/callproc.c index b0a14dc..b2c3061 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -28,7 +28,6 @@ Boston, MA 02111-1307, USA. */ #include "commands.h" #include "insdel.h" #include "lstream.h" -#include #include "process.h" #include "sysdep.h" #include "window.h" @@ -314,19 +313,11 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you { /* child_setup must clobber environ in systems with true vfork. - Protect it from permanent change. */ - REGISTER char **save_environ = environ; - REGISTER int fd1 = fd[1]; - int fd_error = fd1; - char **env; - -#ifdef EMACS_BTL - /* when performance monitoring is on, turn it off before the vfork(), - as the child has no handler for the signal -- when back in the - parent process, turn it back on if it was really on when you "turned - it off" */ - int logging_on = cadillac_stop_logging (); -#endif /* EMACS_BTL */ + Protect it from permanent change. */ + REGISTER char **save_environ = environ; + REGISTER int fd1 = fd[1]; + int fd_error = fd1; + char **env; env = environ; @@ -385,10 +376,6 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you child_setup (filefd, fd1, fd_error, new_argv, (char *) XSTRING_DATA (current_dir)); } -#ifdef EMACS_BTL - else if (logging_on) - cadillac_start_logging (); -#endif if (fd_error >= 0) close (fd_error); @@ -534,9 +521,30 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you +/* Move the file descriptor FD so that its number is not less than MIN. * + The original file descriptor remains open. */ +static int +relocate_fd (int fd, int min) +{ + if (fd >= min) + return fd; + else + { + int newfd = dup (fd); + if (newfd == -1) + { + stderr_out ("Error while setting up child: %s\n", + strerror (errno)); + _exit (1); + } + return relocate_fd (newfd, min); + } +} + /* This is the last thing run in a newly forked inferior either synchronous or asynchronous. - Copy descriptors IN, OUT and ERR as descriptors 0, 1 and 2. + Copy descriptors IN, OUT and ERR + as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO. Initialize inferior's priority, pgrp, connected dir and environment. then exec another program based on new_argv. @@ -554,8 +562,6 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you a decent error from within the child, this should be verified as an executable directory by the parent. */ -static int relocate_fd (int fd, int min); - #ifdef WINDOWSNT int #else @@ -685,29 +691,19 @@ child_setup (int in, int out, int err, char **new_argv, descriptors zero, one, or two; this could happen if Emacs is started with its standard in, out, or error closed, as might happen under X. */ - { - int oin = in, oout = out; - - /* We have to avoid relocating the same descriptor twice! */ - - in = relocate_fd (in, 3); - - if (out == oin) out = in; - else out = relocate_fd (out, 3); - - if (err == oin) err = in; - else if (err == oout) err = out; - else err = relocate_fd (err, 3); - } - - close (0); - close (1); - close (2); - - dup2 (in, 0); - dup2 (out, 1); - dup2 (err, 2); - + in = relocate_fd (in, 3); + out = relocate_fd (out, 3); + err = relocate_fd (err, 3); + + /* Set the standard input/output channels of the new process. */ + close (STDIN_FILENO); + close (STDOUT_FILENO); + close (STDERR_FILENO); + + dup2 (in, STDIN_FILENO); + dup2 (out, STDOUT_FILENO); + dup2 (err, STDERR_FILENO); + close (in); close (out); close (err); @@ -719,9 +715,7 @@ child_setup (int in, int out, int err, char **new_argv, { int fd; for (fd=3; fd<=64; fd++) - { - close(fd); - } + close (fd); } #endif /* not WINDOWSNT */ @@ -749,30 +743,6 @@ child_setup (int in, int out, int err, char **new_argv, #endif /* not WINDOWSNT */ } -/* Move the file descriptor FD so that its number is not less than MIN. - If the file descriptor is moved at all, the original is freed. */ -static int -relocate_fd (int fd, int min) -{ - if (fd >= min) - return fd; - else - { - int new = dup (fd); - if (new == -1) - { - stderr_out ("Error while setting up child: %s\n", - strerror (errno)); - _exit (1); - } - /* Note that we hold the original FD open while we recurse, - to guarantee we'll get a new FD if we need it. */ - new = relocate_fd (new, min); - close (fd); - return new; - } -} - static int getenv_internal (CONST Bufbyte *var, Bytecount varlen, diff --git a/src/casefiddle.c b/src/casefiddle.c index 78f3789..b8a9d1c 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -289,39 +289,39 @@ casify_word (enum case_action flag, Lisp_Object arg, Lisp_Object buffer) } DEFUN ("upcase-word", Fupcase_word, 1, 2, "p", /* -Convert following word (or ARG words) to upper case, moving over. +Convert following word (or N words) to upper case, moving over. With negative argument, convert previous words but do not move. See also `capitalize-word'. Optional second arg BUFFER defaults to the current buffer. */ - (arg, buffer)) + (n, buffer)) { /* This function can GC */ - return casify_word (CASE_UP, arg, buffer); + return casify_word (CASE_UP, n, buffer); } DEFUN ("downcase-word", Fdowncase_word, 1, 2, "p", /* -Convert following word (or ARG words) to lower case, moving over. +Convert following word (or N words) to lower case, moving over. With negative argument, convert previous words but do not move. Optional second arg BUFFER defaults to the current buffer. */ - (arg, buffer)) + (n, buffer)) { /* This function can GC */ - return casify_word (CASE_DOWN, arg, buffer); + return casify_word (CASE_DOWN, n, buffer); } DEFUN ("capitalize-word", Fcapitalize_word, 1, 2, "p", /* -Capitalize the following word (or ARG words), moving over. +Capitalize the following word (or N words), moving over. This gives the word(s) a first character in upper case and the rest lower case. With negative argument, capitalize previous words but do not move. Optional second arg BUFFER defaults to the current buffer. */ - (arg, buffer)) + (n, buffer)) { /* This function can GC */ - return casify_word (CASE_CAPITALIZE, arg, buffer); + return casify_word (CASE_CAPITALIZE, n, buffer); } diff --git a/src/chartab.c b/src/chartab.c index 498cb11..996027d 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -38,7 +38,6 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "chartab.h" -#include "commands.h" #include "syntax.h" Lisp_Object Qchar_tablep, Qchar_table; @@ -98,7 +97,7 @@ mark_char_table_entry (Lisp_Object obj, void (*markobj) (Lisp_Object)) for (i = 0; i < 96; i++) { - (markobj) (cte->level2[i]); + markobj (cte->level2[i]); } return Qnil; } @@ -139,17 +138,17 @@ mark_char_table (Lisp_Object obj, void (*markobj) (Lisp_Object)) int i; for (i = 0; i < NUM_ASCII_CHARS; i++) - (markobj) (ct->ascii[i]); + markobj (ct->ascii[i]); #ifdef MULE for (i = 0; i < NUM_LEADING_BYTES; i++) - (markobj) (ct->level1[i]); + markobj (ct->level1[i]); #endif return ct->mirror_table; } /* WARNING: All functions of this nature need to be written extremely carefully to avoid crashes during GC. Cf. prune_specifiers() - and prune_weak_hashtables(). */ + and prune_weak_hash_tables(). */ void prune_syntax_tables (int (*obj_marked_p) (Lisp_Object)) @@ -160,7 +159,7 @@ prune_syntax_tables (int (*obj_marked_p) (Lisp_Object)) !GC_NILP (rest); rest = XCHAR_TABLE (rest)->next_table) { - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (rest)) { /* This table is garbage. Remove it from the list. */ if (GC_NILP (prev)) @@ -177,6 +176,7 @@ char_table_type_to_symbol (enum char_table_type type) { switch (type) { + default: abort(); case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; @@ -185,9 +185,6 @@ char_table_type_to_symbol (enum char_table_type type) case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; #endif } - - abort (); - return Qnil; /* not reached */ } static enum char_table_type diff --git a/src/cmdloop.c b/src/cmdloop.c index cc07746..5c3d8a6 100644 --- a/src/cmdloop.c +++ b/src/cmdloop.c @@ -35,7 +35,6 @@ Boston, MA 02111-1307, USA. */ #include "commands.h" #include "frame.h" #include "events.h" -#include "macros.h" #include "window.h" /* Current depth in recursive edits. */ diff --git a/src/cmds.c b/src/cmds.c index ad38db4..8e68640 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -43,27 +43,31 @@ Lisp_Object Vself_insert_face; Lisp_Object Vself_insert_face_command; DEFUN ("forward-char", Fforward_char, 0, 2, "_p", /* -Move point right ARG characters (left if ARG negative). +Move point right N characters (left if N negative). On attempt to pass end of buffer, stop and signal `end-of-buffer'. On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'. On reaching end of buffer, stop and signal error. */ - (arg, buffer)) + (n, buffer)) { struct buffer *buf = decode_buffer (buffer, 1); + EMACS_INT count; - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + count = 1; else - CHECK_INT (arg); + { + CHECK_INT (n); + count = XINT (n); + } - /* This used to just set point to point + XINT (arg), and then check + /* This used to just set point to point + XINT (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 proposed position, then set point. */ { - Bufpos new_point = BUF_PT (buf) + XINT (arg); + Bufpos new_point = BUF_PT (buf) + count; if (new_point < BUF_BEGV (buf)) { @@ -85,44 +89,45 @@ On reaching end of buffer, stop and signal error. } DEFUN ("backward-char", Fbackward_char, 0, 2, "_p", /* -Move point left ARG characters (right if ARG negative). +Move point left N characters (right if N negative). On attempt to pass end of buffer, stop and signal `end-of-buffer'. On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'. */ - (arg, buffer)) + (n, buffer)) { - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + n = make_int (-1); else - CHECK_INT (arg); - - XSETINT (arg, - XINT (arg)); - return Fforward_char (arg, buffer); + { + CHECK_INT (n); + XSETINT (n, - XINT (n)); + } + return Fforward_char (n, buffer); } DEFUN ("forward-line", Fforward_line, 0, 2, "_p", /* -Move ARG lines forward (backward if ARG is negative). -Precisely, if point is on line I, move to the start of line I + ARG. +Move N lines forward (backward if N is negative). +Precisely, if point is on line I, move to the start of line I + N. If there isn't room, go as far as possible (no error). Returns the count of lines left to move. If moving forward, -that is ARG - number of lines moved; if backward, ARG + number moved. -With positive ARG, a non-empty line at the end counts as one line +that is N - number of lines moved; if backward, N + number moved. +With positive N, a non-empty line at the end counts as one line successfully moved (for the return value). If BUFFER is nil, the current buffer is assumed. */ - (arg, buffer)) + (n, buffer)) { struct buffer *buf = decode_buffer (buffer, 1); Bufpos pos2 = BUF_PT (buf); Bufpos pos; EMACS_INT count, shortage, negp; - if (NILP (arg)) + if (NILP (n)) count = 1; else { - CHECK_INT (arg); - count = XINT (arg); + CHECK_INT (n); + count = XINT (n); } negp = count <= 0; @@ -143,36 +148,39 @@ With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, return that position. This function does not move point. */ - (arg, buffer)) + (n, buffer)) { struct buffer *b = decode_buffer (buffer, 1); REGISTER int orig, end; XSETBUFFER (buffer, b); - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + n = make_int (0); else - CHECK_INT (arg); + { + CHECK_INT (n); + n = make_int (XINT (n) - 1); + } - orig = BUF_PT(b); - Fforward_line (make_int (XINT (arg) - 1), buffer); - end = BUF_PT(b); - BUF_SET_PT(b, orig); + orig = BUF_PT (b); + Fforward_line (n, buffer); + end = BUF_PT (b); + BUF_SET_PT (b, orig); return make_int (end); } DEFUN ("beginning-of-line", Fbeginning_of_line, 0, 2, "_p", /* Move point to beginning of current line. -With argument ARG not nil or 1, move forward ARG - 1 lines first. +With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, stop there without error. If BUFFER is nil, the current buffer is assumed. */ - (arg, buffer)) + (n, buffer)) { struct buffer *b = decode_buffer (buffer, 1); - BUF_SET_PT(b, XINT (Fpoint_at_bol(arg, buffer))); + BUF_SET_PT (b, XINT (Fpoint_at_bol (n, buffer))); return Qnil; } @@ -182,53 +190,57 @@ With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, return that position. This function does not move point. */ - (arg, buffer)) + (n, buffer)) { struct buffer *buf = decode_buffer (buffer, 1); + int count; - XSETBUFFER (buffer, buf); - - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + count = 1; else - CHECK_INT (arg); + { + CHECK_INT (n); + count = XINT (n); + } return make_int (find_before_next_newline (buf, BUF_PT (buf), 0, - XINT (arg) - (XINT (arg) <= 0))); + count - (count <= 0))); } DEFUN ("end-of-line", Fend_of_line, 0, 2, "_p", /* Move point to end of current line. -With argument ARG not nil or 1, move forward ARG - 1 lines first. +With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, stop there without error. If BUFFER is nil, the current buffer is assumed. */ - (arg, buffer)) + (n, buffer)) { struct buffer *b = decode_buffer (buffer, 1); - BUF_SET_PT(b, XINT (Fpoint_at_eol (arg, buffer))); + BUF_SET_PT (b, XINT (Fpoint_at_eol (n, buffer))); return Qnil; } DEFUN ("delete-char", Fdelete_char, 1, 2, "*p\nP", /* -Delete the following ARG characters (previous, with negative arg). +Delete the following N characters (previous, with negative N). Optional second arg KILLFLAG non-nil means kill instead (save in kill ring). -Interactively, ARG is the prefix arg, and KILLFLAG is set if -ARG was explicitly specified. +Interactively, N is the prefix arg, and KILLFLAG is set if +N was explicitly specified. */ - (arg, killflag)) + (n, killflag)) { /* This function can GC */ Bufpos pos; struct buffer *buf = current_buffer; + int count; - CHECK_INT (arg); + CHECK_INT (n); + count = XINT (n); - pos = BUF_PT (buf) + XINT (arg); + pos = BUF_PT (buf) + count; if (NILP (killflag)) { - if (XINT (arg) < 0) + if (count < 0) { if (pos < BUF_BEGV (buf)) signal_error (Qbeginning_of_buffer, Qnil); @@ -245,22 +257,22 @@ ARG was explicitly specified. } else { - call1 (Qkill_forward_chars, arg); + call1 (Qkill_forward_chars, n); } return Qnil; } DEFUN ("delete-backward-char", Fdelete_backward_char, 1, 2, "*p\nP", /* -Delete the previous ARG characters (following, with negative ARG). +Delete the previous N characters (following, with negative N). Optional second arg KILLFLAG non-nil means kill instead (save in kill ring). -Interactively, ARG is the prefix arg, and KILLFLAG is set if -ARG was explicitly specified. +Interactively, N is the prefix arg, and KILLFLAG is set if +N was explicitly specified. */ - (arg, killflag)) + (n, killflag)) { /* This function can GC */ - CHECK_INT (arg); - return Fdelete_char (make_int (-XINT (arg)), killflag); + CHECK_INT (n); + return Fdelete_char (make_int (- XINT (n)), killflag); } static void internal_self_insert (Emchar ch, int noautofill); @@ -269,13 +281,15 @@ DEFUN ("self-insert-command", Fself_insert_command, 1, 1, "*p", /* Insert the character you type. Whichever character you type to run this command is inserted. */ - (arg)) + (n)) { /* This function can GC */ - int n; Emchar ch; Lisp_Object c; - CHECK_INT (arg); + int count; + + CHECK_NATNUM (n); + count = XINT (n); if (CHAR_OR_CHAR_INTP (Vlast_command_char)) c = Vlast_command_char; @@ -283,36 +297,16 @@ Whichever character you type to run this command is inserted. c = Fevent_to_character (Vlast_command_event, Qnil, Qnil, Qt); if (NILP (c)) - signal_simple_error ("last typed character has no ASCII equivalent", + signal_simple_error ("Last typed character has no ASCII equivalent", Fcopy_event (Vlast_command_event, Qnil)); CHECK_CHAR_COERCE_INT (c); - n = XINT (arg); ch = XCHAR (c); -#if 0 /* FSFmacs */ - /* #### This optimization won't work because of differences in - how the start-open and end-open properties default for text - properties. See internal_self_insert(). */ - if (n >= 2 && NILP (current_buffer->overwrite_mode)) - { - n -= 2; - /* The first one might want to expand an abbrev. */ - internal_self_insert (c, 1); - /* The bulk of the copies of this char can be inserted simply. - We don't have to handle a user-specified face specially - because it will get inherited from the first char inserted. */ - Finsert_char (make_char (c), make_int (n), Qt, Qnil); - /* The last one might want to auto-fill. */ - internal_self_insert (c, 0); - } - else -#endif /* 0 */ - while (n > 0) - { - n--; - internal_self_insert (ch, (n != 0)); - } + + while (count--) + internal_self_insert (ch, (count != 0)); + return Qnil; } @@ -335,6 +329,7 @@ internal_self_insert (Emchar c1, int noautofill) Lisp_Object overwrite; struct Lisp_Char_Table *syntax_table; struct buffer *buf = current_buffer; + int tab_width; overwrite = buf->overwrite_mode; syntax_table = XCHAR_TABLE (buf->mirror_syntax_table); @@ -354,9 +349,9 @@ internal_self_insert (Emchar c1, int noautofill) || (c1 != '\n' && BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\n')) && (EQ (overwrite, Qoverwrite_mode_binary) || BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\t' - || XINT (buf->tab_width) <= 0 - || XINT (buf->tab_width) > 20 - || !((current_column (buf) + 1) % XINT (buf->tab_width)))) + || ((tab_width = XINT (buf->tab_width), tab_width <= 0) + || tab_width > 20 + || !((current_column (buf) + 1) % tab_width)))) { buffer_delete_range (buf, BUF_PT (buf), BUF_PT (buf) + 1, 0); /* hairy = 2; */ diff --git a/src/config.h.in b/src/config.h.in index eae4bbc..a9acd10 100644 --- a/src/config.h.in +++ b/src/config.h.in @@ -403,11 +403,19 @@ char *alloca(); determine where XEmacs' memory is going. */ #undef MEMORY_USAGE_STATS -/* Define QUANTIFY if using Quantify from Pure/Atria Software. +/* Define QUANTIFY if using Quantify from Rational/Pure/Atria Software. This adds some additional calls to control data collection. It is only intended for use by the developers. */ #undef QUANTIFY +/* Define QUANTIFY if using Purify from Rational/Pure/Atria Software. + It is only intended for use by the developers. */ +#undef PURIFY + +#if (defined (QUANTIFY) || defined (PURIFY)) && !defined (XLIB_ILLEGAL_ACCESS) +#define XLIB_ILLEGAL_ACCESS 1 +#endif + /* Define EXTERNAL_WIDGET to compile support for using the editor as a widget within another program. */ #undef EXTERNAL_WIDGET diff --git a/src/conslots.h b/src/conslots.h index df6ef9b..dfa9752 100644 --- a/src/conslots.h +++ b/src/conslots.h @@ -46,7 +46,7 @@ Boston, MA 02111-1307, USA. */ /* Most-recently-selected non-minibuffer-only frame. Always the same as the selected frame, unless that's a minibuffer-only frame. */ - MARKED_SLOT (_last_nonminibuf_frame); + MARKED_SLOT (last_nonminibuf_frame); /* If non-nil, a keymap that overrides all others but applies only to this console. Lisp code that uses this instead of calling next-event diff --git a/src/console-msw.h b/src/console-msw.h index 45e2561..2f48d95 100644 --- a/src/console-msw.h +++ b/src/console-msw.h @@ -133,7 +133,7 @@ struct mswindows_frame /* DC for this win32 window */ HDC hdc; - /* compatibke DC for bitmap operations */ + /* compatible DC for bitmap operations */ HDC cdc; /* Time of last click event, for button 2 emul */ @@ -142,13 +142,13 @@ struct mswindows_frame /* Coordinates of last click event, screen-relative */ POINTS last_click_point; #ifdef HAVE_TOOLBARS - /* Toolbar hashtable. See toolbar-msw.c */ - Lisp_Object toolbar_hashtable; + /* Toolbar hash table. See toolbar-msw.c */ + Lisp_Object toolbar_hash_table; unsigned int toolbar_checksum[4]; #endif - /* Menu hashtable. See menubar-msw.c */ - Lisp_Object menu_hashtable; + /* Menu hash table. See menubar-msw.c */ + Lisp_Object menu_hash_table; /* Menu checksum. See menubar-msw.c */ unsigned int menu_checksum; @@ -175,12 +175,12 @@ struct mswindows_frame #define FRAME_MSWINDOWS_DATA(f) FRAME_TYPE_DATA (f, mswindows) -#define FRAME_MSWINDOWS_HANDLE(f) (FRAME_MSWINDOWS_DATA (f)->hwnd) -#define FRAME_MSWINDOWS_DC(f) (FRAME_MSWINDOWS_DATA (f)->hdc) -#define FRAME_MSWINDOWS_CDC(f) (FRAME_MSWINDOWS_DATA (f)->cdc) -#define FRAME_MSWINDOWS_MENU_HASHTABLE(f) (FRAME_MSWINDOWS_DATA (f)->menu_hashtable) -#define FRAME_MSWINDOWS_TOOLBAR_HASHTABLE(f) \ - (FRAME_MSWINDOWS_DATA (f)->toolbar_hashtable) +#define FRAME_MSWINDOWS_HANDLE(f) (FRAME_MSWINDOWS_DATA (f)->hwnd) +#define FRAME_MSWINDOWS_DC(f) (FRAME_MSWINDOWS_DATA (f)->hdc) +#define FRAME_MSWINDOWS_CDC(f) (FRAME_MSWINDOWS_DATA (f)->cdc) +#define FRAME_MSWINDOWS_MENU_HASH_TABLE(f) (FRAME_MSWINDOWS_DATA (f)->menu_hash_table) +#define FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f) \ + (FRAME_MSWINDOWS_DATA (f)->toolbar_hash_table) #define FRAME_MSWINDOWS_TOOLBAR_CHECKSUM(f,pos) \ (FRAME_MSWINDOWS_DATA (f)->toolbar_checksum[pos]) #define FRAME_MSWINDOWS_MENU_CHECKSUM(f) (FRAME_MSWINDOWS_DATA (f)->menu_checksum) diff --git a/src/console-tty.c b/src/console-tty.c index f4196b8..24fa971 100644 --- a/src/console-tty.c +++ b/src/console-tty.c @@ -32,7 +32,6 @@ Boston, MA 02111-1307, USA. */ #include "faces.h" #include "frame.h" #include "lstream.h" -#include "redisplay.h" #include "sysdep.h" #include "sysfile.h" #ifdef FILE_CODING @@ -165,9 +164,9 @@ static void tty_mark_console (struct console *con, void (*markobj) (Lisp_Object)) { struct tty_console *tty_con = CONSOLE_TTY_DATA (con); - ((markobj) (tty_con->terminal_type)); - ((markobj) (tty_con->instream)); - ((markobj) (tty_con->outstream)); + markobj (tty_con->terminal_type); + markobj (tty_con->instream); + markobj (tty_con->outstream); } static int diff --git a/src/console-tty.h b/src/console-tty.h index 5c521ad..3b88295 100644 --- a/src/console-tty.h +++ b/src/console-tty.h @@ -220,21 +220,17 @@ struct tty_console #define TTY_FLAGS(c) (CONSOLE_TTY_DATA (c)->flags) #define TTY_COST(c) (CONSOLE_TTY_DATA (c)->cost) -#define TTY_INC_CURSOR_X(c, n) \ -do \ -{ \ - int __tempn__ = (n); \ +#define TTY_INC_CURSOR_X(c, n) do { \ + int TICX_n = (n); \ assert (CONSOLE_TTY_CURSOR_X (c) == CONSOLE_TTY_REAL_CURSOR_X (c)); \ - CONSOLE_TTY_CURSOR_X (c) += __tempn__; \ - CONSOLE_TTY_REAL_CURSOR_X (c) += __tempn__; \ + CONSOLE_TTY_CURSOR_X (c) += TICX_n; \ + CONSOLE_TTY_REAL_CURSOR_X (c) += TICX_n; \ } while (0) -#define TTY_INC_CURSOR_Y(c, n) \ -do \ -{ \ - int __tempn__ = (n); \ - CONSOLE_TTY_CURSOR_Y (c) += __tempn__; \ - CONSOLE_TTY_REAL_CURSOR_Y (c) += __tempn__; \ +#define TTY_INC_CURSOR_Y(c, n) do { \ + int TICY_n = (n); \ + CONSOLE_TTY_CURSOR_Y (c) += TICY_n; \ + CONSOLE_TTY_REAL_CURSOR_Y (c) += TICY_n; \ } while (0) struct tty_device diff --git a/src/console-x.c b/src/console-x.c index 67c0bd5..4a4ab21 100644 --- a/src/console-x.c +++ b/src/console-x.c @@ -104,7 +104,7 @@ get_display_arg_connection (void) { CONST char *disp_name; - /* If the user didn't explicitly specifify a display to use when + /* If the user didn't explicitly specify a display to use when they called make-x-device, then we first check to see if a display was specified on the command line with -display. If so, we set disp_name to it. Otherwise we use XDisplayName to diff --git a/src/console-x.h b/src/console-x.h index aa1f594..e285226 100644 --- a/src/console-x.h +++ b/src/console-x.h @@ -134,7 +134,7 @@ struct x_device int x_keysym_map_min_code; int x_keysym_map_max_code; int x_keysym_map_keysyms_per_code; - Lisp_Object x_keysym_map_hashtable; + Lisp_Object x_keysym_map_hash_table; /* frame that holds the WM_COMMAND property; there should be exactly one of these per device. */ @@ -198,7 +198,7 @@ struct x_device #define DEVICE_X_MOUSE_TIMESTAMP(d) (DEVICE_X_DATA (d)->mouse_timestamp) #define DEVICE_X_GLOBAL_MOUSE_TIMESTAMP(d) (DEVICE_X_DATA (d)->global_mouse_timestamp) #define DEVICE_X_LAST_SERVER_TIMESTAMP(d) (DEVICE_X_DATA (d)->last_server_timestamp) -#define DEVICE_X_KEYSYM_MAP_HASHTABLE(d) (DEVICE_X_DATA (d)->x_keysym_map_hashtable) +#define DEVICE_X_KEYSYM_MAP_HASH_TABLE(d) (DEVICE_X_DATA (d)->x_keysym_map_hash_table) /* #define DEVICE_X_X_COMPOSE_STATUS(d) (DEVICE_X_DATA (d)->x_compose_status) */ #ifdef HAVE_XIM #define DEVICE_X_XIM(d) (DEVICE_X_DATA (d)->xim) diff --git a/src/console.c b/src/console.c index 7190364..550e5f8 100644 --- a/src/console.c +++ b/src/console.c @@ -100,14 +100,14 @@ mark_console (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct console *con = XCONSOLE (obj); -#define MARKED_SLOT(x) ((markobj) (con->x)); +#define MARKED_SLOT(x) ((void) (markobj (con->x))); #include "conslots.h" #undef MARKED_SLOT /* Can be zero for Vconsole_defaults, Vconsole_local_symbols */ if (con->conmeths) { - ((markobj) (con->conmeths->symbol)); + markobj (con->conmeths->symbol); MAYBE_CONMETH (con, mark_console, (con, markobj)); } @@ -285,7 +285,7 @@ void set_console_last_nonminibuf_frame (struct console *con, Lisp_Object frame) { - con->_last_nonminibuf_frame = frame; + con->last_nonminibuf_frame = frame; } DEFUN ("consolep", Fconsolep, 1, 1, 0, /* @@ -1141,71 +1141,43 @@ One argument, the to-be-deleted console. #endif } -/* DOC is ignored because it is snagged and recorded externally - * by make-docfile */ +/* The docstrings for DEFVAR_* are recorded externally by make-docfile. */ + /* Declaring this stuff as const produces 'Cannot reinitialize' messages from SunPro C's fix-and-continue feature (a way neato feature that makes debugging unbelievably more bearable) */ -#define DEFVAR_CONSOLE_LOCAL(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_SELECTED_CONSOLE_FORWARD }, 0 }; \ - defvar_console_local ((lname), &I_hate_C); \ -} while (0) - -#define DEFVAR_CONSOLE_LOCAL_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_SELECTED_CONSOLE_FORWARD }, magicfun }; \ - defvar_console_local ((lname), &I_hate_C); \ -} while (0) - -#define DEFVAR_CONST_CONSOLE_LOCAL(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_CONST_SELECTED_CONSOLE_FORWARD }, 0 }; \ - defvar_console_local ((lname), &I_hate_C); \ -} while (0) - -#define DEFVAR_CONST_CONSOLE_LOCAL_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_CONST_SELECTED_CONSOLE_FORWARD }, magicfun }; \ - defvar_console_local ((lname), &I_hate_C); \ -} while (0) - -#define DEFVAR_CONSOLE_DEFAULTS(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_CONSOLE_FORWARD }, 0 }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ -} while (0) - -#define DEFVAR_CONSOLE_DEFAULTS_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_CONSOLE_FORWARD }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ +#define DEFVAR_CONSOLE_LOCAL_1(lname, field_name, forward_type, magicfun) do { \ + static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ + = { { { symbol_value_forward_lheader_initializer, \ + (struct lcrecord_header *) &(console_local_flags.field_name), 69 }, \ + forward_type }, magicfun }; \ + { \ + int offset = ((char *)symbol_value_forward_forward (&I_hate_C) \ + - (char *)&console_local_flags); \ + \ + defvar_magic (lname, &I_hate_C); \ + \ + *((Lisp_Object *)(offset + (char *)XCONSOLE (Vconsole_local_symbols))) \ + = intern (lname); \ + } \ } while (0) -static void -defvar_console_local (CONST char *namestring, - CONST struct symbol_value_forward *m) -{ - int offset = ((char *)symbol_value_forward_forward (m) - - (char *)&console_local_flags); - - defvar_mumble (namestring, m, sizeof (*m)); - - *((Lisp_Object *)(offset + (char *)XCONSOLE (Vconsole_local_symbols))) - = intern (namestring); -} +#define DEFVAR_CONSOLE_LOCAL_MAGIC(lname, field_name, magicfun) \ + DEFVAR_CONSOLE_LOCAL_1 (lname, field_name, \ + SYMVAL_SELECTED_CONSOLE_FORWARD, magicfun) +#define DEFVAR_CONSOLE_LOCAL(lname, field_name) \ + DEFVAR_CONSOLE_LOCAL_MAGIC (lname, field_name, 0) +#define DEFVAR_CONST_CONSOLE_LOCAL_MAGIC(lname, field_name, magicfun) \ + DEFVAR_CONSOLE_LOCAL_1 (lname, field_name, \ + SYMVAL_CONST_SELECTED_CONSOLE_FORWARD, magicfun) +#define DEFVAR_CONST_CONSOLE_LOCAL(lname, field_name) \ + DEFVAR_CONST_CONSOLE_LOCAL_MAGIC (lname, field_name, 0) + +#define DEFVAR_CONSOLE_DEFAULTS_MAGIC(lname, field_name, magicfun) \ + DEFVAR_SYMVAL_FWD(lname, &(console_local_flags.field_name), \ + SYMVAL_DEFAULT_CONSOLE_FORWARD, magicfun) +#define DEFVAR_CONSOLE_DEFAULTS(lname, field_name) \ + DEFVAR_CONSOLE_DEFAULTS_MAGIC (lname, field_name, 0) static void nuke_all_console_slots (struct console *con, Lisp_Object zap) diff --git a/src/console.h b/src/console.h index 2ba1b15..757a492 100644 --- a/src/console.h +++ b/src/console.h @@ -37,7 +37,7 @@ Boston, MA 02111-1307, USA. */ always tagged to a particular X window (i.e. frame), which exists on only one screen; therefore the event won't be reported multiple times even if there are multiple devices on - the same physical display. This is an implementational detail + the same physical display. This is an implementation detail specific to X consoles (e.g. under NeXTstep or Windows, this could be different, and input would come directly from the console). */ @@ -209,7 +209,7 @@ struct console_methods int depth); void (*init_image_instance_from_eimage_method) (struct Lisp_Image_Instance *ii, int width, int height, - unsigned char *eimage, + unsigned char *eimage, int dest_mask, Lisp_Object instantiator, Lisp_Object domain); @@ -218,17 +218,17 @@ struct console_methods Lisp_Object fg, Lisp_Object bg); #ifdef HAVE_XPM /* which is more tacky - this or #defines in glyphs.c? */ - void (*xpm_instantiate_method)(Lisp_Object image_instance, + void (*xpm_instantiate_method)(Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, int dest_mask, Lisp_Object domain); #endif #ifdef HAVE_WINDOW_SYSTEM /* which is more tacky - this or #defines in glyphs.c? */ - void (*xbm_instantiate_method)(Lisp_Object image_instance, + void (*xbm_instantiate_method)(Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, int dest_mask, Lisp_Object domain); #endif @@ -297,9 +297,9 @@ struct console_methods /* Call a void-returning console method, if it exists */ #define MAYBE_CONTYPE_METH(meth, m, args) do { \ - struct console_methods *_maybe_contype_meth_meth = (meth); \ - if (HAS_CONTYPE_METH_P (_maybe_contype_meth_meth, m)) \ - CONTYPE_METH (_maybe_contype_meth_meth, m, args); \ + struct console_methods *maybe_contype_meth_meth = (meth); \ + if (HAS_CONTYPE_METH_P (maybe_contype_meth_meth, m)) \ + CONTYPE_METH (maybe_contype_meth_meth, m, args); \ } while (0) /* Call a console method, if it exists; otherwise return @@ -531,7 +531,7 @@ int valid_console_type_p (Lisp_Object type); #define CONSOLE_SELECTED_DEVICE(con) ((con)->selected_device) #define CONSOLE_SELECTED_FRAME(con) \ DEVICE_SELECTED_FRAME (XDEVICE ((con)->selected_device)) -#define CONSOLE_LAST_NONMINIBUF_FRAME(con) NON_LVALUE ((con)->_last_nonminibuf_frame) +#define CONSOLE_LAST_NONMINIBUF_FRAME(con) NON_LVALUE ((con)->last_nonminibuf_frame) #define CONSOLE_QUIT_CHAR(con) ((con)->quit_char) #define CDFW_CONSOLE(obj) \ diff --git a/src/data.c b/src/data.c index c0f2c54..4e4a274 100644 --- a/src/data.c +++ b/src/data.c @@ -52,7 +52,7 @@ Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error; Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp; Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp; -Lisp_Object Qconsp, Qsubrp, Qcompiled_functionp; +Lisp_Object Qconsp, Qsubrp; Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp; Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp; Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p; @@ -77,15 +77,17 @@ int debug_ebola_backtrace_length; int eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2) { - if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) - && (debug_issue_ebola_notices >= 2 - || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))) + if (debug_issue_ebola_notices != -42 /* abracadabra */ && + (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) + && (debug_issue_ebola_notices >= 2 + || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2)))) { - stderr_out("Comparison between integer and character is constant nil ("); + write_c_string ("Comparison between integer and character is constant nil (", + Qexternal_debugging_output); Fprinc (obj1, Qexternal_debugging_output); - stderr_out (" and "); + write_c_string (" and ", Qexternal_debugging_output); Fprinc (obj2, Qexternal_debugging_output); - stderr_out (")\n"); + write_c_string (")\n", Qexternal_debugging_output); debug_short_backtrace (debug_ebola_backtrace_length); } return EQ (obj1, obj2); @@ -207,7 +209,7 @@ Return t if OBJECT is nil. } DEFUN ("consp", Fconsp, 1, 1, 0, /* -Return t if OBJECT is a cons cell. +Return t if OBJECT is a cons cell. `nil' is not a cons cell. */ (object)) { @@ -215,7 +217,7 @@ Return t if OBJECT is a cons cell. } DEFUN ("atom", Fatom, 1, 1, 0, /* -Return t if OBJECT is not a cons cell. Atoms include nil. +Return t if OBJECT is not a cons cell. `nil' is not a cons cell. */ (object)) { @@ -223,7 +225,7 @@ Return t if OBJECT is not a cons cell. Atoms include nil. } DEFUN ("listp", Flistp, 1, 1, 0, /* -Return t if OBJECT is a list. Lists includes nil. +Return t if OBJECT is a list. `nil' is a list. */ (object)) { @@ -231,7 +233,7 @@ Return t if OBJECT is a list. Lists includes nil. } DEFUN ("nlistp", Fnlistp, 1, 1, 0, /* -Return t if OBJECT is not a list. Lists include nil. +Return t if OBJECT is not a list. `nil' is a list. */ (object)) { @@ -263,7 +265,7 @@ Return t if OBJECT is a keyword. } DEFUN ("vectorp", Fvectorp, 1, 1, 0, /* -REturn t if OBJECT is a vector. +Return t if OBJECT is a vector. */ (object)) { @@ -302,8 +304,7 @@ Return t if OBJECT is a sequence (list or array). */ (object)) { - return (CONSP (object) || - NILP (object) || + return (LISTP (object) || VECTORP (object) || STRINGP (object) || BIT_VECTORP (object)) @@ -363,14 +364,6 @@ If non-nil, the return value will be a list whose first element is return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil; } -DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* -Return t if OBJECT is a byte-compiled function object. -*/ - (object)) -{ - return COMPILED_FUNCTIONP (object) ? Qt : Qnil; -} - DEFUN ("characterp", Fcharacterp, 1, 1, 0, /* Return t if OBJECT is a character. @@ -551,16 +544,31 @@ Return a symbol representing the type of OBJECT. */ (object)) { - if (CONSP (object)) return Qcons; - if (SYMBOLP (object)) return Qsymbol; - if (KEYWORDP (object)) return Qkeyword; - if (INTP (object)) return Qinteger; - if (CHARP (object)) return Qcharacter; - if (STRINGP (object)) return Qstring; - if (VECTORP (object)) return Qvector; + switch (XTYPE (object)) + { +#ifndef LRECORD_CONS + case Lisp_Type_Cons: return Qcons; +#endif + +#ifndef LRECORD_SYMBOL + case Lisp_Type_Symbol: return Qsymbol; +#endif - assert (LRECORDP (object)); - return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); +#ifndef LRECORD_STRING + case Lisp_Type_String: return Qstring; +#endif + +#ifndef LRECORD_VECTOR + case Lisp_Type_Vector: return Qvector; +#endif + + case Lisp_Type_Record: + return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); + + case Lisp_Type_Char: return Qcharacter; + + default: return Qinteger; + } } @@ -642,9 +650,9 @@ Set the cdr of CONSCELL to be NEWCDR. Return NEWCDR. return newcdr; } -/* Find the function at the end of a chain of symbol function indirections. */ +/* Find the function at the end of a chain of symbol function indirections. -/* If OBJECT is a symbol, find the end of its function chain and + If OBJECT is a symbol, find the end of its function chain and return the value found there. If OBJECT is not a symbol, just return it. If there is a cycle in the function chain, signal a cyclic-function-indirection error. @@ -654,26 +662,25 @@ Set the cdr of CONSCELL to be NEWCDR. Return NEWCDR. Lisp_Object indirect_function (Lisp_Object object, int errorp) { - Lisp_Object tortoise = object; - Lisp_Object hare = object; +#define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16 + Lisp_Object tortoise, hare; + int count; - for (;;) + for (hare = tortoise = object, count = 0; + SYMBOLP (hare); + hare = XSYMBOL (hare)->function, count++) { - if (!SYMBOLP (hare) || UNBOUNDP (hare)) - break; - hare = XSYMBOL (hare)->function; - if (!SYMBOLP (hare) || UNBOUNDP (hare)) - break; - hare = XSYMBOL (hare)->function; - - tortoise = XSYMBOL (tortoise)->function; + if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue; + if (count & 1) + tortoise = XSYMBOL (tortoise)->function; if (EQ (hare, tortoise)) return Fsignal (Qcyclic_function_indirection, list1 (object)); } - if (UNBOUNDP (hare) && errorp) - return Fsignal (Qvoid_function, list1 (object)); + if (errorp && UNBOUNDP (hare)) + signal_void_function_error (object); + return hare; } @@ -695,41 +702,44 @@ function chain of symbols. DEFUN ("aref", Faref, 2, 2, 0, /* Return the element of ARRAY at index INDEX. -ARRAY may be a vector, bit vector, string, or byte-code object. -IDX starts at 0. +ARRAY may be a vector, bit vector, or string. INDEX starts at 0. */ - (array, idx)) + (array, index_)) { - int idxval; + int idx; retry: - CHECK_INT_COERCE_CHAR (idx); /* yuck! */ - idxval = XINT (idx); - if (idxval < 0) + + if (INTP (index_)) idx = XINT (index_); + else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ + else { - lose: - args_out_of_range (array, idx); + index_ = wrong_type_argument (Qinteger_or_char_p, index_); + goto retry; } + + if (idx < 0) goto range_error; + if (VECTORP (array)) { - if (idxval >= XVECTOR_LENGTH (array)) goto lose; - return XVECTOR_DATA (array)[idxval]; + if (idx >= XVECTOR_LENGTH (array)) goto range_error; + return XVECTOR_DATA (array)[idx]; } else if (BIT_VECTORP (array)) { - if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose; - return make_int (bit_vector_bit (XBIT_VECTOR (array), idxval)); + if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error; + return make_int (bit_vector_bit (XBIT_VECTOR (array), idx)); } else if (STRINGP (array)) { - if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose; - return make_char (string_char (XSTRING (array), idxval)); + if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error; + return make_char (string_char (XSTRING (array), idx)); } #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (array)) { /* Weird, gross compatibility kludge */ - return Felt (array, idx); + return Felt (array, index_); } #endif else @@ -738,290 +748,148 @@ IDX starts at 0. array = wrong_type_argument (Qarrayp, array); goto retry; } + + range_error: + args_out_of_range (array, index_); + return Qnil; /* not reached */ } DEFUN ("aset", Faset, 3, 3, 0, /* -Store into the element of ARRAY at index IDX the value NEWVAL. -ARRAY may be a vector, bit vector, or string. IDX starts at 0. +Store into the element of ARRAY at index INDEX the value NEWVAL. +ARRAY may be a vector, bit vector, or string. INDEX starts at 0. */ - (array, idx, newval)) + (array, index_, newval)) { - int idxval; + int idx; - CHECK_INT_COERCE_CHAR (idx); /* yuck! */ - if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array)) - array = wrong_type_argument (Qarrayp, array); + retry: - idxval = XINT (idx); - if (idxval < 0) + if (INTP (index_)) idx = XINT (index_); + else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ + else { - lose: - args_out_of_range (array, idx); + index_ = wrong_type_argument (Qinteger_or_char_p, index_); + goto retry; } + + if (idx < 0) goto range_error; + CHECK_IMPURE (array); if (VECTORP (array)) { - if (idxval >= XVECTOR_LENGTH (array)) goto lose; - XVECTOR_DATA (array)[idxval] = newval; + if (idx >= XVECTOR_LENGTH (array)) goto range_error; + XVECTOR_DATA (array)[idx] = newval; } else if (BIT_VECTORP (array)) { - if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose; + if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error; CHECK_BIT (newval); - set_bit_vector_bit (XBIT_VECTOR (array), idxval, !ZEROP (newval)); + set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval)); } - else /* string */ + else if (STRINGP (array)) { CHECK_CHAR_COERCE_INT (newval); - if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose; - set_string_char (XSTRING (array), idxval, XCHAR (newval)); + if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error; + set_string_char (XSTRING (array), idx, XCHAR (newval)); bump_string_modiff (array); } + else + { + array = wrong_type_argument (Qarrayp, array); + goto retry; + } return newval; + + range_error: + args_out_of_range (array, index_); + return Qnil; /* not reached */ } /**********************************************************************/ -/* Compiled-function objects */ +/* Arithmetic functions */ /**********************************************************************/ - -/* The compiled_function->doc_and_interactive slot uses the minimal - number of conses, based on compiled_function->flags; it may take - any of the following forms: - - doc - interactive - domain - (doc . interactive) - (doc . domain) - (interactive . domain) - (doc . (interactive . domain)) - */ - -/* Caller must check flags.interactivep first */ -Lisp_Object -compiled_function_interactive (struct Lisp_Compiled_Function *b) +typedef struct { - assert (b->flags.interactivep); - if (b->flags.documentationp && b->flags.domainp) - return XCAR (XCDR (b->doc_and_interactive)); - else if (b->flags.documentationp) - return XCDR (b->doc_and_interactive); - else if (b->flags.domainp) - return XCAR (b->doc_and_interactive); - - /* if all else fails... */ - return b->doc_and_interactive; -} + int int_p; + union + { + int ival; + double dval; + } c; +} int_or_double; -/* Caller need not check flags.documentationp first */ -Lisp_Object -compiled_function_documentation (struct Lisp_Compiled_Function *b) -{ - if (! b->flags.documentationp) - return Qnil; - else if (b->flags.interactivep && b->flags.domainp) - return XCAR (b->doc_and_interactive); - else if (b->flags.interactivep) - return XCAR (b->doc_and_interactive); - else if (b->flags.domainp) - return XCAR (b->doc_and_interactive); - else - return b->doc_and_interactive; -} - -/* Caller need not check flags.domainp first */ -Lisp_Object -compiled_function_domain (struct Lisp_Compiled_Function *b) -{ - if (! b->flags.domainp) - return Qnil; - else if (b->flags.documentationp && b->flags.interactivep) - return XCDR (XCDR (b->doc_and_interactive)); - else if (b->flags.documentationp) - return XCDR (b->doc_and_interactive); - else if (b->flags.interactivep) - return XCDR (b->doc_and_interactive); - else - return b->doc_and_interactive; -} - -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - -Lisp_Object -compiled_function_annotation (struct Lisp_Compiled_Function *b) +static void +number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p) { - return b->annotated; -} - + retry: + p->int_p = 1; + if (INTP (obj)) p->c.ival = XINT (obj); + else if (CHARP (obj)) p->c.ival = XCHAR (obj); + else if (MARKERP (obj)) p->c.ival = marker_position (obj); +#ifdef LISP_FLOAT_TYPE + else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0; #endif - -/* used only by Snarf-documentation; there must be doc already. */ -void -set_compiled_function_documentation (struct Lisp_Compiled_Function *b, - Lisp_Object new) -{ - assert (b->flags.documentationp); - assert (INTP (new) || STRINGP (new)); - - if (b->flags.interactivep && b->flags.domainp) - XCAR (b->doc_and_interactive) = new; - else if (b->flags.interactivep) - XCAR (b->doc_and_interactive) = new; - else if (b->flags.domainp) - XCAR (b->doc_and_interactive) = new; else - b->doc_and_interactive = new; -} - -DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* -Return the byte-opcode string of the compiled-function object. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return XCOMPILED_FUNCTION (function)->bytecodes; -} - -DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* -Return the constants vector of the compiled-function object. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return XCOMPILED_FUNCTION (function)->constants; -} - -DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* -Return the max stack depth of the compiled-function object. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return make_int (XCOMPILED_FUNCTION (function)->maxdepth); -} - -DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* -Return the argument list of the compiled-function object. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return XCOMPILED_FUNCTION (function)->arglist; -} - -DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* -Return the interactive spec of the compiled-function object, or nil. -If non-nil, the return value will be a list whose first element is -`interactive' and whose second element is the interactive spec. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return XCOMPILED_FUNCTION (function)->flags.interactivep - ? list2 (Qinteractive, - compiled_function_interactive (XCOMPILED_FUNCTION (function))) - : Qnil; -} - -DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* -Return the doc string of the compiled-function object, if available. -Functions that had their doc strings snarfed into the DOC file will have -an integer returned instead of a string. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return compiled_function_documentation (XCOMPILED_FUNCTION (function)); -} - -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - -/* Remove the `xx' if you wish to restore this feature */ -xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* -Return the annotation of the compiled-function object, or nil. -The annotation is a piece of information indicating where this -compiled-function object came from. Generally this will be -a symbol naming a function; or a string naming a file, if the -compiled-function object was not defined in a function; or nil, -if the compiled-function object was not created as a result of -a `load'. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return compiled_function_annotation (XCOMPILED_FUNCTION (function)); -} - -#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ - -DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* -Return the domain of the compiled-function object, or nil. -This is only meaningful if I18N3 was enabled when emacs was compiled. -*/ - (function)) -{ - CHECK_COMPILED_FUNCTION (function); - return XCOMPILED_FUNCTION (function)->flags.domainp - ? compiled_function_domain (XCOMPILED_FUNCTION (function)) - : Qnil; + { + obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); + goto retry; + } } - -/**********************************************************************/ -/* Arithmetic functions */ -/**********************************************************************/ - -Lisp_Object -arithcompare (Lisp_Object num1, Lisp_Object num2, - enum arith_comparison comparison) +static double +number_char_or_marker_to_double (Lisp_Object obj) { - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1); - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2); - + retry: + if (INTP (obj)) return (double) XINT (obj); + else if (CHARP (obj)) return (double) XCHAR (obj); + else if (MARKERP (obj)) return (double) marker_position (obj); #ifdef LISP_FLOAT_TYPE - if (FLOATP (num1) || FLOATP (num2)) + else if (FLOATP (obj)) return XFLOAT_DATA (obj); +#endif + else { - double f1 = FLOATP (num1) ? float_data (XFLOAT (num1)) : XINT (num1); - double f2 = FLOATP (num2) ? float_data (XFLOAT (num2)) : XINT (num2); - - switch (comparison) - { - case arith_equal: return f1 == f2 ? Qt : Qnil; - case arith_notequal: return f1 != f2 ? Qt : Qnil; - case arith_less: return f1 < f2 ? Qt : Qnil; - case arith_less_or_equal: return f1 <= f2 ? Qt : Qnil; - case arith_grtr: return f1 > f2 ? Qt : Qnil; - case arith_grtr_or_equal: return f1 >= f2 ? Qt : Qnil; - } + obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); + goto retry; } -#endif /* LISP_FLOAT_TYPE */ +} - switch (comparison) +static int +integer_char_or_marker_to_int (Lisp_Object obj) +{ + retry: + if (INTP (obj)) return XINT (obj); + else if (CHARP (obj)) return XCHAR (obj); + else if (MARKERP (obj)) return marker_position (obj); + else { - case arith_equal: return XINT (num1) == XINT (num2) ? Qt : Qnil; - case arith_notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil; - case arith_less: return XINT (num1) < XINT (num2) ? Qt : Qnil; - case arith_less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil; - case arith_grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil; - case arith_grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil; + obj = wrong_type_argument (Qinteger_char_or_marker_p, obj); + goto retry; } - - abort (); - return Qnil; /* suppress compiler warning */ } -static Lisp_Object -arithcompare_many (enum arith_comparison comparison, - int nargs, Lisp_Object *args) -{ - for (; --nargs > 0; args++) - if (NILP (arithcompare (*args, *(args + 1), comparison))) - return Qnil; - - return Qt; +#define ARITHCOMPARE_MANY(op) \ +{ \ + int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \ + Lisp_Object *args_end = args + nargs; \ + \ + number_char_or_marker_to_int_or_double (*args++, p); \ + \ + while (args < args_end) \ + { \ + number_char_or_marker_to_int_or_double (*args++, q); \ + \ + if (!((p->int_p && q->int_p) ? \ + (p->c.ival op q->c.ival) : \ + ((p->int_p ? (double) p->c.ival : p->c.dval) op \ + (q->int_p ? (double) q->c.ival : q->c.dval)))) \ + return Qnil; \ + \ + { /* swap */ int_or_double *r = p; p = q; q = r; } \ + } \ + return Qt; \ } DEFUN ("=", Feqlsign, 1, MANY, 0, /* @@ -1030,7 +898,7 @@ The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_equal, nargs, args); + ARITHCOMPARE_MANY (==) } DEFUN ("<", Flss, 1, MANY, 0, /* @@ -1039,7 +907,7 @@ The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_less, nargs, args); + ARITHCOMPARE_MANY (<) } DEFUN (">", Fgtr, 1, MANY, 0, /* @@ -1048,7 +916,7 @@ The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_grtr, nargs, args); + ARITHCOMPARE_MANY (>) } DEFUN ("<=", Fleq, 1, MANY, 0, /* @@ -1057,7 +925,7 @@ The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_less_or_equal, nargs, args); + ARITHCOMPARE_MANY (<=) } DEFUN (">=", Fgeq, 1, MANY, 0, /* @@ -1066,7 +934,7 @@ The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_grtr_or_equal, nargs, args); + ARITHCOMPARE_MANY (>=) } DEFUN ("/=", Fneq, 1, MANY, 0, /* @@ -1075,7 +943,28 @@ The arguments may be numbers, characters or markers. */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_notequal, nargs, args); + Lisp_Object *args_end = args + nargs; + Lisp_Object *p, *q; + + /* Unlike all the other comparisons, this is an N*N algorithm. + We could use a hash table for nargs > 50 to make this linear. */ + for (p = args; p < args_end; p++) + { + int_or_double iod1, iod2; + number_char_or_marker_to_int_or_double (*p, &iod1); + + for (q = p + 1; q < args_end; q++) + { + number_char_or_marker_to_int_or_double (*q, &iod2); + + if (!((iod1.int_p && iod2.int_p) ? + (iod1.c.ival != iod2.c.ival) : + ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) != + (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval)))) + return Qnil; + } + } + return Qt; } DEFUN ("zerop", Fzerop, 1, 1, 0, /* @@ -1083,14 +972,18 @@ Return t if NUMBER is zero. */ (number)) { - CHECK_INT_OR_FLOAT (number); - + retry: + if (INTP (number)) + return EQ (number, Qzero) ? Qt : Qnil; #ifdef LISP_FLOAT_TYPE - if (FLOATP (number)) - return float_data (XFLOAT (number)) == 0.0 ? Qt : Qnil; + else if (FLOATP (number)) + return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil; #endif /* LISP_FLOAT_TYPE */ - - return EQ (number, Qzero) ? Qt : Qnil; + else + { + number = wrong_type_argument (Qnumberp, number); + goto retry; + } } /* Convert between a 32-bit value and a cons of two 16-bit values. @@ -1138,7 +1031,7 @@ NUM may be an integer or a floating point number. { char pigbuf[350]; /* see comments in float_to_string */ - float_to_string (pigbuf, float_data (XFLOAT (num))); + float_to_string (pigbuf, XFLOAT_DATA (num)); return build_string (pigbuf); } #endif /* LISP_FLOAT_TYPE */ @@ -1199,7 +1092,7 @@ Floating point numbers always use base 10. if (b == 10) { /* Use the system-provided functions for base 10. */ -#if SIZEOF_EMACS_INT == SIZEOF_INT +#if SIZEOF_EMACS_INT == SIZEOF_INT return make_int (atoi (p)); #elif SIZEOF_EMACS_INT == SIZEOF_LONG return make_int (atol (p)); @@ -1230,180 +1123,308 @@ Floating point numbers always use base 10. } } -enum arithop - { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; +DEFUN ("+", Fplus, 0, MANY, 0, /* +Return sum of any number of arguments. +The arguments should all be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + EMACS_INT iaccum = 0; + Lisp_Object *args_end = args + nargs; -#ifdef LISP_FLOAT_TYPE -static Lisp_Object -float_arith_driver (double accum, int argnum, enum arithop code, int nargs, - Lisp_Object *args) + while (args < args_end) + { + int_or_double iod; + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum += iod.c.ival; + else + { + double daccum = (double) iaccum + iod.c.dval; + while (args < args_end) + daccum += number_char_or_marker_to_double (*args++); + return make_float (daccum); + } + } + + return make_int (iaccum); +} + +DEFUN ("-", Fminus, 1, MANY, 0, /* +Negate number or subtract numbers, characters or markers. +With one arg, negates it. With more than one arg, +subtracts all but the first from the first. +*/ + (int nargs, Lisp_Object *args)) { - REGISTER Lisp_Object val; - double next; + EMACS_INT iaccum; + double daccum; + Lisp_Object *args_end = args + nargs; + int_or_double iod; - for (; argnum < nargs; argnum++) + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival; + else { - /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */ - val = args[argnum]; - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val); + daccum = nargs > 1 ? iod.c.dval : - iod.c.dval; + goto do_float; + } - if (FLOATP (val)) + while (args < args_end) + { + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum -= iod.c.ival; + else { - next = float_data (XFLOAT (val)); + daccum = (double) iaccum - iod.c.dval; + goto do_float; } + } + + return make_int (iaccum); + + do_float: + for (; args < args_end; args++) + daccum -= number_char_or_marker_to_double (*args); + return make_float (daccum); +} + +DEFUN ("*", Ftimes, 0, MANY, 0, /* +Return product of any number of arguments. +The arguments should all be numbers, characters or markers. +*/ + (int nargs, Lisp_Object *args)) +{ + EMACS_INT iaccum = 1; + Lisp_Object *args_end = args + nargs; + + while (args < args_end) + { + int_or_double iod; + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum *= iod.c.ival; else { - args[argnum] = val; /* runs into a compiler bug. */ - next = XINT (args[argnum]); + double daccum = (double) iaccum * iod.c.dval; + while (args < args_end) + daccum *= number_char_or_marker_to_double (*args++); + return make_float (daccum); } - switch (code) + } + + return make_int (iaccum); +} + +DEFUN ("/", Fquo, 1, MANY, 0, /* +Return first argument divided by all the remaining arguments. +The arguments must be numbers, characters or markers. +With one argument, reciprocates the argument. +*/ + (int nargs, Lisp_Object *args)) +{ + EMACS_INT iaccum; + double daccum; + Lisp_Object *args_end = args + nargs; + int_or_double iod; + + if (nargs == 1) + iaccum = 1; + else + { + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum = iod.c.ival; + else { - case Aadd: - accum += next; - break; - case Asub: - if (!argnum && nargs != 1) - next = - next; - accum -= next; - break; - case Amult: - accum *= next; - break; - case Adiv: - if (!argnum) - accum = next; - else - { - if (next == 0) - Fsignal (Qarith_error, Qnil); - accum /= next; - } - break; - case Alogand: - case Alogior: - case Alogxor: - return wrong_type_argument (Qinteger_char_or_marker_p, val); - case Amax: - if (!argnum || isnan (next) || next > accum) - accum = next; - break; - case Amin: - if (!argnum || isnan (next) || next < accum) - accum = next; - break; + daccum = iod.c.dval; + goto divide_floats; } } - return make_float (accum); + while (args < args_end) + { + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + { + if (iod.c.ival == 0) goto divide_by_zero; + iaccum /= iod.c.ival; + } + else + { + if (iod.c.dval == 0) goto divide_by_zero; + daccum = (double) iaccum / iod.c.dval; + goto divide_floats; + } + } + + return make_int (iaccum); + + divide_floats: + for (; args < args_end; args++) + { + double dval = number_char_or_marker_to_double (*args); + if (dval == 0) goto divide_by_zero; + daccum /= dval; + } + return make_float (daccum); + + divide_by_zero: + Fsignal (Qarith_error, Qnil); + return Qnil; /* not reached */ } -#endif /* LISP_FLOAT_TYPE */ -static Lisp_Object -arith_driver (enum arithop code, int nargs, Lisp_Object *args) +DEFUN ("max", Fmax, 1, MANY, 0, /* +Return largest of all the arguments. +All arguments must be numbers, characters or markers. +The value is always a number; markers and characters are converted +to numbers. +*/ + (int nargs, Lisp_Object *args)) { - Lisp_Object val; - REGISTER int argnum; - REGISTER EMACS_INT accum = 0; - REGISTER EMACS_INT next; + EMACS_INT imax; + double dmax; + Lisp_Object *args_end = args + nargs; + int_or_double iod; - switch (code) + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + imax = iod.c.ival; + else { - case Alogior: - case Alogxor: - case Aadd: - case Asub: - accum = 0; break; - case Amult: - accum = 1; break; - case Alogand: - accum = -1; break; - case Adiv: - case Amax: - case Amin: - accum = 0; break; - default: - abort (); + dmax = iod.c.dval; + goto max_floats; } - for (argnum = 0; argnum < nargs; argnum++) + while (args < args_end) { - /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */ - val = args[argnum]; - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val); - -#ifdef LISP_FLOAT_TYPE - if (FLOATP (val)) /* time to do serious math */ - return float_arith_driver ((double) accum, argnum, code, - nargs, args); -#endif /* LISP_FLOAT_TYPE */ - args[argnum] = val; /* runs into a compiler bug. */ - next = XINT (args[argnum]); - switch (code) + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) { - case Aadd: accum += next; break; - case Asub: - if (!argnum && nargs != 1) - next = - next; - accum -= next; - break; - case Amult: accum *= next; break; - case Adiv: - if (!argnum) accum = next; - else - { - if (next == 0) - Fsignal (Qarith_error, Qnil); - accum /= next; - } - break; - case Alogand: accum &= next; break; - case Alogior: accum |= next; break; - case Alogxor: accum ^= next; break; - case Amax: if (!argnum || next > accum) accum = next; break; - case Amin: if (!argnum || next < accum) accum = next; break; + if (imax < iod.c.ival) imax = iod.c.ival; + } + else + { + dmax = (double) imax; + if (dmax < iod.c.dval) dmax = iod.c.dval; + goto max_floats; } } - XSETINT (val, accum); - return val; + return make_int (imax); + + max_floats: + while (args < args_end) + { + double dval = number_char_or_marker_to_double (*args++); + if (dmax < dval) dmax = dval; + } + return make_float (dmax); } -DEFUN ("+", Fplus, 0, MANY, 0, /* -Return sum of any number of arguments. -The arguments should all be numbers, characters or markers. +DEFUN ("min", Fmin, 1, MANY, 0, /* +Return smallest of all the arguments. +All arguments must be numbers, characters or markers. +The value is always a number; markers and characters are converted +to numbers. */ (int nargs, Lisp_Object *args)) { - return arith_driver (Aadd, nargs, args); + EMACS_INT imin; + double dmin; + Lisp_Object *args_end = args + nargs; + int_or_double iod; + + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + imin = iod.c.ival; + else + { + dmin = iod.c.dval; + goto min_floats; + } + + while (args < args_end) + { + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + { + if (imin > iod.c.ival) imin = iod.c.ival; + } + else + { + dmin = (double) imin; + if (dmin > iod.c.dval) dmin = iod.c.dval; + goto min_floats; + } + } + + return make_int (imin); + + min_floats: + while (args < args_end) + { + double dval = number_char_or_marker_to_double (*args++); + if (dmin > dval) dmin = dval; + } + return make_float (dmin); } -DEFUN ("-", Fminus, 0, MANY, 0, /* -Negate number or subtract numbers, characters or markers. -With one arg, negates it. With more than one arg, -subtracts all but the first from the first. +DEFUN ("logand", Flogand, 0, MANY, 0, /* +Return bitwise-and of all the arguments. +Arguments may be integers, or markers or characters converted to integers. */ (int nargs, Lisp_Object *args)) { - return arith_driver (Asub, nargs, args); + EMACS_INT bits = ~0; + Lisp_Object *args_end = args + nargs; + + while (args < args_end) + bits &= integer_char_or_marker_to_int (*args++); + + return make_int (bits); } -DEFUN ("*", Ftimes, 0, MANY, 0, /* -Return product of any number of arguments. -The arguments should all be numbers, characters or markers. +DEFUN ("logior", Flogior, 0, MANY, 0, /* +Return bitwise-or of all the arguments. +Arguments may be integers, or markers or characters converted to integers. */ (int nargs, Lisp_Object *args)) { - return arith_driver (Amult, nargs, args); + EMACS_INT bits = 0; + Lisp_Object *args_end = args + nargs; + + while (args < args_end) + bits |= integer_char_or_marker_to_int (*args++); + + return make_int (bits); } -DEFUN ("/", Fquo, 2, MANY, 0, /* -Return first argument divided by all the remaining arguments. -The arguments must be numbers, characters or markers. +DEFUN ("logxor", Flogxor, 0, MANY, 0, /* +Return bitwise-exclusive-or of all the arguments. +Arguments may be integers, or markers or characters converted to integers. */ (int nargs, Lisp_Object *args)) { - return arith_driver (Adiv, nargs, args); + EMACS_INT bits = 0; + Lisp_Object *args_end = args + nargs; + + while (args < args_end) + bits ^= integer_char_or_marker_to_int (*args++); + + return make_int (bits); +} + +DEFUN ("lognot", Flognot, 1, 1, 0, /* +Return the bitwise complement of NUMBER. +NUMBER may be an integer, marker or character converted to integer. +*/ + (number)) +{ + return make_int (~ integer_char_or_marker_to_int (number)); } DEFUN ("%", Frem, 2, 2, 0, /* @@ -1412,13 +1433,13 @@ Both must be integers, characters or markers. */ (num1, num2)) { - CHECK_INT_COERCE_CHAR_OR_MARKER (num1); - CHECK_INT_COERCE_CHAR_OR_MARKER (num2); + int ival1 = integer_char_or_marker_to_int (num1); + int ival2 = integer_char_or_marker_to_int (num2); - if (ZEROP (num2)) + if (ival2 == 0) Fsignal (Qarith_error, Qnil); - return make_int (XINT (num1) % XINT (num2)); + return make_int (ival1 % ival2); } /* Note, ANSI *requires* the presence of the fmod() library routine. @@ -1444,96 +1465,41 @@ If either argument is a float, a float will be returned. */ (x, y)) { - EMACS_INT i1, i2; + int_or_double iod1, iod2; + number_char_or_marker_to_int_or_double (x, &iod1); + number_char_or_marker_to_int_or_double (y, &iod2); #ifdef LISP_FLOAT_TYPE - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x); - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y); - - if (FLOATP (x) || FLOATP (y)) + if (!iod1.int_p || !iod2.int_p) { - double f1, f2; - - f1 = ((FLOATP (x)) ? float_data (XFLOAT (x)) : XINT (x)); - f2 = ((FLOATP (y)) ? float_data (XFLOAT (y)) : XINT (y)); - if (f2 == 0) - Fsignal (Qarith_error, Qnil); - - f1 = fmod (f1, f2); + double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval; + double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval; + if (dval2 == 0) goto divide_by_zero; + dval1 = fmod (dval1, dval2); /* If the "remainder" comes out with the wrong sign, fix it. */ - if (f2 < 0 ? f1 > 0 : f1 < 0) - f1 += f2; - return make_float (f1); - } -#else /* not LISP_FLOAT_TYPE */ - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x); - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y); -#endif /* not LISP_FLOAT_TYPE */ - - i1 = XINT (x); - i2 = XINT (y); - - if (i2 == 0) - Fsignal (Qarith_error, Qnil); - - i1 %= i2; - - /* If the "remainder" comes out with the wrong sign, fix it. */ - if (i2 < 0 ? i1 > 0 : i1 < 0) - i1 += i2; - - return make_int (i1); -} - + if (dval2 < 0 ? dval1 > 0 : dval1 < 0) + dval1 += dval2; -DEFUN ("max", Fmax, 1, MANY, 0, /* -Return largest of all the arguments. -All arguments must be numbers, characters or markers. -The value is always a number; markers and characters are converted -to numbers. -*/ - (int nargs, Lisp_Object *args)) -{ - return arith_driver (Amax, nargs, args); -} + return make_float (dval1); + } +#endif /* LISP_FLOAT_TYPE */ + { + int ival; + if (iod2.c.ival == 0) goto divide_by_zero; -DEFUN ("min", Fmin, 1, MANY, 0, /* -Return smallest of all the arguments. -All arguments must be numbers, characters or markers. -The value is always a number; markers and characters are converted -to numbers. -*/ - (int nargs, Lisp_Object *args)) -{ - return arith_driver (Amin, nargs, args); -} + ival = iod1.c.ival % iod2.c.ival; -DEFUN ("logand", Flogand, 0, MANY, 0, /* -Return bitwise-and of all the arguments. -Arguments may be integers, or markers or characters converted to integers. -*/ - (int nargs, Lisp_Object *args)) -{ - return arith_driver (Alogand, nargs, args); -} + /* If the "remainder" comes out with the wrong sign, fix it. */ + if (iod2.c.ival < 0 ? ival > 0 : ival < 0) + ival += iod2.c.ival; -DEFUN ("logior", Flogior, 0, MANY, 0, /* -Return bitwise-or of all the arguments. -Arguments may be integers, or markers or characters converted to integers. -*/ - (int nargs, Lisp_Object *args)) -{ - return arith_driver (Alogior, nargs, args); -} + return make_int (ival); + } -DEFUN ("logxor", Flogxor, 0, MANY, 0, /* -Return bitwise-exclusive-or of all the arguments. -Arguments may be integers, or markers or characters converted to integers. -*/ - (int nargs, Lisp_Object *args)) -{ - return arith_driver (Alogxor, nargs, args); + divide_by_zero: + Fsignal (Qarith_error, Qnil); + return Qnil; /* not reached */ } DEFUN ("ash", Fash, 2, 2, 0, /* @@ -1544,7 +1510,7 @@ In this case, the sign bit is duplicated. (value, count)) { CHECK_INT_COERCE_CHAR (value); - CHECK_INT (count); + CONCHECK_INT (count); return make_int (XINT (count) > 0 ? XINT (value) << XINT (count) : @@ -1559,7 +1525,7 @@ In this case, zeros are shifted in on the left. (value, count)) { CHECK_INT_COERCE_CHAR (value); - CHECK_INT (count); + CONCHECK_INT (count); return make_int (XINT (count) > 0 ? XUINT (value) << XINT (count) : @@ -1567,44 +1533,41 @@ In this case, zeros are shifted in on the left. } DEFUN ("1+", Fadd1, 1, 1, 0, /* -Return NUMBER plus one. NUMBER may be a number or a marker. +Return NUMBER plus one. NUMBER may be a number, character or marker. Markers and characters are converted to integers. */ (number)) { - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number); + retry: + if (INTP (number)) return make_int (XINT (number) + 1); + if (CHARP (number)) return make_int (XCHAR (number) + 1); + if (MARKERP (number)) return make_int (marker_position (number) + 1); #ifdef LISP_FLOAT_TYPE - if (FLOATP (number)) - return make_float (1.0 + float_data (XFLOAT (number))); + if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0); #endif /* LISP_FLOAT_TYPE */ - return make_int (XINT (number) + 1); + number = wrong_type_argument (Qnumber_char_or_marker_p, number); + goto retry; } DEFUN ("1-", Fsub1, 1, 1, 0, /* -Return NUMBER minus one. NUMBER may be a number or a marker. +Return NUMBER minus one. NUMBER may be a number, character or marker. Markers and characters are converted to integers. */ (number)) { - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number); + retry: + if (INTP (number)) return make_int (XINT (number) - 1); + if (CHARP (number)) return make_int (XCHAR (number) - 1); + if (MARKERP (number)) return make_int (marker_position (number) - 1); #ifdef LISP_FLOAT_TYPE - if (FLOATP (number)) - return make_float (-1.0 + (float_data (XFLOAT (number)))); + if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0); #endif /* LISP_FLOAT_TYPE */ - return make_int (XINT (number) - 1); -} - -DEFUN ("lognot", Flognot, 1, 1, 0, /* -Return the bitwise complement of NUMBER. NUMBER must be an integer. -*/ - (number)) -{ - CHECK_INT (number); - return make_int (~XINT (number)); + number = wrong_type_argument (Qnumber_char_or_marker_p, number); + goto retry; } @@ -1616,7 +1579,7 @@ Return the bitwise complement of NUMBER. NUMBER must be an integer. disappear when no longer in use, i.e. when no longer GC-protected. The basic idea is that we don't mark the elements during GC, but wait for them to be marked elsewhere. If they're not marked, we - remove them. This is analogous to weak hashtables; see the explanation + remove them. This is analogous to weak hash tables; see the explanation there for more info. */ static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ @@ -1644,10 +1607,10 @@ print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } static int -weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth) +weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct weak_list *w1 = XWEAK_LIST (o1); - struct weak_list *w2 = XWEAK_LIST (o2); + struct weak_list *w1 = XWEAK_LIST (obj1); + struct weak_list *w2 = XWEAK_LIST (obj2); return ((w1->type == w2->type) && internal_equal (w1->list, w2->list, depth + 1)); @@ -1712,7 +1675,7 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), Lisp_Object rest2; enum weak_list_type type = XWEAK_LIST (rest)->type; - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (rest)) /* The weak list is probably garbage. Ignore it. */ continue; @@ -1735,7 +1698,7 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), (either because of an external pointer or because of a previous call to this function), and likewise for all the rest of the elements in the list, so we can stop now. */ - if ((*obj_marked_p) (rest2)) + if (obj_marked_p (rest2)) break; elem = XCAR (rest2); @@ -1743,7 +1706,7 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), switch (type) { case WEAK_LIST_SIMPLE: - if ((*obj_marked_p) (elem)) + if (obj_marked_p (elem)) need_to_mark_cons = 1; break; @@ -1754,8 +1717,8 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), need_to_mark_cons = 1; need_to_mark_elem = 1; } - else if ((*obj_marked_p) (XCAR (elem)) && - (*obj_marked_p) (XCDR (elem))) + else if (obj_marked_p (XCAR (elem)) && + obj_marked_p (XCDR (elem))) { need_to_mark_cons = 1; /* We still need to mark elem, because it's @@ -1771,7 +1734,7 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), need_to_mark_cons = 1; need_to_mark_elem = 1; } - else if ((*obj_marked_p) (XCAR (elem))) + else if (obj_marked_p (XCAR (elem))) { need_to_mark_cons = 1; /* We still need to mark elem and XCDR (elem); @@ -1787,7 +1750,7 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), need_to_mark_cons = 1; need_to_mark_elem = 1; } - else if ((*obj_marked_p) (XCDR (elem))) + else if (obj_marked_p (XCDR (elem))) { need_to_mark_cons = 1; /* We still need to mark elem and XCAR (elem); @@ -1800,9 +1763,9 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), abort (); } - if (need_to_mark_elem && ! (*obj_marked_p) (elem)) + if (need_to_mark_elem && ! obj_marked_p (elem)) { - (*markobj) (elem); + markobj (elem); did_mark = 1; } @@ -1824,9 +1787,9 @@ finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object), /* In case of imperfect list, need to mark the final cons because we're not removing it */ - if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2)) + if (!GC_NILP (rest2) && ! obj_marked_p (rest2)) { - (markobj) (rest2); + markobj (rest2); did_mark = 1; } } @@ -1843,7 +1806,7 @@ prune_weak_lists (int (*obj_marked_p) (Lisp_Object)) !GC_NILP (rest); rest = XWEAK_LIST (rest)->next_weak) { - if (! ((*obj_marked_p) (rest))) + if (! (obj_marked_p (rest))) { /* This weak list itself is garbage. Remove it from the list. */ if (GC_NILP (prev)) @@ -1873,7 +1836,7 @@ prune_weak_lists (int (*obj_marked_p) (Lisp_Object)) have been marked in finish_marking_weak_lists(). -- otherwise, it's not marked and should disappear. */ - if (!(*obj_marked_p) (rest2)) + if (! obj_marked_p (rest2)) { /* bye bye :-( */ if (GC_NILP (prev2)) @@ -2086,14 +2049,17 @@ init_errors_once_early (void) "Attempt to set a constant symbol", Qerror); deferror (&Qinvalid_read_syntax, "invalid-read-syntax", "Invalid read syntax", Qerror); + + /* Generated by list traversal macros */ deferror (&Qmalformed_list, "malformed-list", "Malformed list", Qerror); deferror (&Qmalformed_property_list, "malformed-property-list", - "Malformed property list", Qerror); + "Malformed property list", Qmalformed_list); deferror (&Qcircular_list, "circular-list", "Circular list", Qerror); deferror (&Qcircular_property_list, "circular-property-list", - "Circular property list", Qerror); + "Circular property list", Qcircular_list); + deferror (&Qinvalid_function, "invalid-function", "Invalid function", Qerror); deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments", @@ -2146,7 +2112,6 @@ syms_of_data (void) defsymbol (&Qbitp, "bitp"); defsymbol (&Qbit_vectorp, "bit-vector-p"); defsymbol (&Qvectorp, "vectorp"); - defsymbol (&Qcompiled_functionp, "compiled-function-p"); defsymbol (&Qchar_or_string_p, "char-or-string-p"); defsymbol (&Qmarkerp, "markerp"); defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p"); @@ -2167,6 +2132,7 @@ syms_of_data (void) DEFSUBR (Feq); DEFSUBR (Fold_eq); DEFSUBR (Fnull); + Ffset (intern ("not"), intern ("null")); DEFSUBR (Flistp); DEFSUBR (Fnlistp); DEFSUBR (Ftrue_list_p); @@ -2202,7 +2168,6 @@ syms_of_data (void) DEFSUBR (Fsubr_min_args); DEFSUBR (Fsubr_max_args); DEFSUBR (Fsubr_interactive); - DEFSUBR (Fcompiled_function_p); DEFSUBR (Ftype_of); DEFSUBR (Fcar); DEFSUBR (Fcdr); @@ -2214,17 +2179,6 @@ syms_of_data (void) DEFSUBR (Faref); DEFSUBR (Faset); - DEFSUBR (Fcompiled_function_instructions); - DEFSUBR (Fcompiled_function_constants); - DEFSUBR (Fcompiled_function_stack_depth); - DEFSUBR (Fcompiled_function_arglist); - DEFSUBR (Fcompiled_function_interactive); - DEFSUBR (Fcompiled_function_doc_string); - DEFSUBR (Fcompiled_function_domain); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - DEFSUBR (Fcompiled_function_annotation); -#endif - DEFSUBR (Fnumber_to_string); DEFSUBR (Fstring_to_number); DEFSUBR (Feqlsign); @@ -2266,9 +2220,9 @@ vars_of_data (void) #ifdef DEBUG_XEMACS DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* -If non-nil, note when your code may be suffering from char-int confoundance. +If non-zero, note when your code may be suffering from char-int confoundance. That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', -etc. where a int and a char with the same value are being compared, +etc. where an int and a char with the same value are being compared, it will issue a notice on stderr to this effect, along with a backtrace. In such situations, the result would be different in XEmacs 19 versus XEmacs 20, and you probably don't want this. diff --git a/src/database.c b/src/database.c index c30e990..c42d41f 100644 --- a/src/database.c +++ b/src/database.c @@ -27,6 +27,7 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" #include "sysfile.h" +#include "buffer.h" #include #ifndef HAVE_DATABASE @@ -65,29 +66,34 @@ Lisp_Object Qhash, Qbtree, Qrecno, Qunknown; Lisp_Object Qdbm; #endif /* HAVE_DBM */ -Lisp_Object Qdatabasep; +#ifdef MULE +/* #### The following should be settable on a per-database level. + But the whole coding-system infrastructure should be rewritten someday. + We really need coding-system aliases. -- martin */ +Lisp_Object Vdatabase_coding_system; +#endif -typedef enum { DB_DBM, DB_BERKELEY, DB_IS_UNKNOWN } XEMACS_DB_TYPE; +Lisp_Object Qdatabasep; struct Lisp_Database; +typedef struct Lisp_Database Lisp_Database; typedef struct { - Lisp_Object (*get_subtype) (struct Lisp_Database *); - Lisp_Object (*get_type) (struct Lisp_Database *); - Lisp_Object (*get) (struct Lisp_Database *, Lisp_Object); - int (*put) (struct Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); - int (*rem) (struct Lisp_Database *, Lisp_Object); - void (*map) (struct Lisp_Database *, Lisp_Object); - void (*close) (struct Lisp_Database *); - Lisp_Object (*last_error) (struct Lisp_Database *); + Lisp_Object (*get_subtype) (Lisp_Database *); + Lisp_Object (*get_type) (Lisp_Database *); + Lisp_Object (*get) (Lisp_Database *, Lisp_Object); + int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); + int (*rem) (Lisp_Database *, Lisp_Object); + void (*map) (Lisp_Database *, Lisp_Object); + void (*close) (Lisp_Database *); + Lisp_Object (*last_error) (Lisp_Database *); } DB_FUNCS; struct Lisp_Database { struct lcrecord_header header; Lisp_Object fname; - XEMACS_DB_TYPE type; int mode; int access_; int dberrno; @@ -104,7 +110,7 @@ struct Lisp_Database #endif }; -#define XDATABASE(x) XRECORD (x, database, struct Lisp_Database) +#define XDATABASE(x) XRECORD (x, database, Lisp_Database) #define XSETDATABASE(x, p) XSETRECORD (x, p, database) #define DATABASEP(x) RECORDP (x, database) #define GC_DATABASEP(x) GC_RECORDP (x, database) @@ -119,11 +125,10 @@ struct Lisp_Database } while (0) -static struct Lisp_Database * +static Lisp_Database * allocate_database (void) { - struct Lisp_Database *db = - alloc_lcrecord_type (struct Lisp_Database, lrecord_database); + Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, lrecord_database); db->fname = Qnil; db->live_p = 0; @@ -136,7 +141,6 @@ allocate_database (void) db->access_ = 0; db->mode = 0; db->dberrno = 0; - db->type = DB_IS_UNKNOWN; #ifdef MULE db->coding_system = Fget_coding_system (Qbinary); #endif @@ -146,9 +150,9 @@ allocate_database (void) static Lisp_Object mark_database (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct Lisp_Database *db = XDATABASE (obj); + Lisp_Database *db = XDATABASE (obj); - ((markobj) (db->fname)); + markobj (db->fname); return Qnil; } @@ -156,7 +160,7 @@ static void print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { char buf[64]; - struct Lisp_Database *db = XDATABASE (obj); + Lisp_Database *db = XDATABASE (obj); if (print_readably) error ("printing unreadable object #", db->header.uid); @@ -176,12 +180,12 @@ print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) static void finalize_database (void *header, int for_disksave) { - struct Lisp_Database *db = (struct Lisp_Database *) header; + Lisp_Database *db = (Lisp_Database *) header; if (for_disksave) { Lisp_Object obj; - XSETOBJ (obj, Lisp_Type_Record, (void *) db); + XSETDATABASE (obj, db); signal_simple_error ("Can't dump an emacs containing database objects", obj); @@ -192,14 +196,14 @@ finalize_database (void *header, int for_disksave) DEFINE_LRECORD_IMPLEMENTATION ("database", database, mark_database, print_database, finalize_database, 0, 0, - struct Lisp_Database); + Lisp_Database); DEFUN ("close-database", Fclose_database, 1, 1, 0, /* Close database DATABASE. */ (database)) { - struct Lisp_Database *db; + Lisp_Database *db; CHECK_LIVE_DATABASE (database); db = XDATABASE (database); db->funcs->close (db); @@ -255,7 +259,7 @@ Return t if OBJ is a database. #ifdef HAVE_DBM static void -dbm_map (struct Lisp_Database *db, Lisp_Object func) +dbm_map (Lisp_Database *db, Lisp_Object func) { datum keydatum, valdatum; Lisp_Object key, val; @@ -272,7 +276,7 @@ dbm_map (struct Lisp_Database *db, Lisp_Object func) } static Lisp_Object -dbm_get (struct Lisp_Database *db, Lisp_Object key) +dbm_get (Lisp_Database *db, Lisp_Object key) { datum keydatum, valdatum; @@ -286,7 +290,7 @@ dbm_get (struct Lisp_Database *db, Lisp_Object key) } static int -dbm_put (struct Lisp_Database *db, +dbm_put (Lisp_Database *db, Lisp_Object key, Lisp_Object val, Lisp_Object replace) { datum keydatum, valdatum; @@ -301,7 +305,7 @@ dbm_put (struct Lisp_Database *db, } static int -dbm_remove (struct Lisp_Database *db, Lisp_Object key) +dbm_remove (Lisp_Database *db, Lisp_Object key) { datum keydatum; @@ -312,25 +316,25 @@ dbm_remove (struct Lisp_Database *db, Lisp_Object key) } static Lisp_Object -dbm_type (struct Lisp_Database *db) +dbm_type (Lisp_Database *db) { return Qdbm; } static Lisp_Object -dbm_subtype (struct Lisp_Database *db) +dbm_subtype (Lisp_Database *db) { return Qnil; } static Lisp_Object -dbm_lasterr (struct Lisp_Database *db) +dbm_lasterr (Lisp_Database *db) { return lisp_strerror (db->dberrno); } static void -dbm_closeit (struct Lisp_Database *db) +dbm_closeit (Lisp_Database *db) { if (db->dbm_handle) { @@ -354,13 +358,13 @@ static DB_FUNCS ndbm_func_block = #ifdef HAVE_BERKELEY_DB static Lisp_Object -berkdb_type (struct Lisp_Database *db) +berkdb_type (Lisp_Database *db) { return Qberkeley_db; } static Lisp_Object -berkdb_subtype (struct Lisp_Database *db) +berkdb_subtype (Lisp_Database *db) { if (!db->db_handle) return Qnil; @@ -375,23 +379,20 @@ berkdb_subtype (struct Lisp_Database *db) } static Lisp_Object -berkdb_lasterr (struct Lisp_Database *db) +berkdb_lasterr (Lisp_Database *db) { return lisp_strerror (db->dberrno); } static Lisp_Object -berkdb_get (struct Lisp_Database *db, Lisp_Object key) +berkdb_get (Lisp_Database *db, Lisp_Object key) { - /* #### Needs mule-izing */ DBT keydatum, valdatum; int status = 0; -#if DB_VERSION_MAJOR == 2 - /* Always initialize keydatum, valdatum. */ + /* DB Version 2 requires DBT's to be zeroed before use. */ xzero (keydatum); xzero (valdatum); -#endif /* DV_VERSION_MAJOR = 2 */ keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); @@ -403,6 +404,7 @@ berkdb_get (struct Lisp_Database *db, Lisp_Object key) #endif /* DB_VERSION_MAJOR */ if (!status) + /* #### Not mule-ized! will crash! */ return make_string ((Bufbyte *) valdatum.data, valdatum.size); #if DB_VERSION_MAJOR == 1 @@ -415,7 +417,7 @@ berkdb_get (struct Lisp_Database *db, Lisp_Object key) } static int -berkdb_put (struct Lisp_Database *db, +berkdb_put (Lisp_Database *db, Lisp_Object key, Lisp_Object val, Lisp_Object replace) @@ -423,11 +425,9 @@ berkdb_put (struct Lisp_Database *db, DBT keydatum, valdatum; int status = 0; -#if DB_VERSION_MAJOR == 2 - /* Always initalize keydatum, valdatum. */ + /* DB Version 2 requires DBT's to be zeroed before use. */ xzero (keydatum); xzero (valdatum); -#endif /* DV_VERSION_MAJOR = 2 */ keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); @@ -447,15 +447,13 @@ berkdb_put (struct Lisp_Database *db, } static int -berkdb_remove (struct Lisp_Database *db, Lisp_Object key) +berkdb_remove (Lisp_Database *db, Lisp_Object key) { DBT keydatum; int status; -#if DB_VERSION_MAJOR == 2 - /* Always initialize keydatum. */ + /* DB Version 2 requires DBT's to be zeroed before use. */ xzero (keydatum); -#endif /* DV_VERSION_MAJOR = 2 */ keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); @@ -479,13 +477,16 @@ berkdb_remove (struct Lisp_Database *db, Lisp_Object key) } static void -berkdb_map (struct Lisp_Database *db, Lisp_Object func) +berkdb_map (Lisp_Database *db, Lisp_Object func) { DBT keydatum, valdatum; Lisp_Object key, val; DB *dbp = db->db_handle; int status; + xzero (keydatum); + xzero (valdatum); + #if DB_VERSION_MAJOR == 1 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); status == 0; @@ -498,9 +499,6 @@ berkdb_map (struct Lisp_Database *db, Lisp_Object func) } #else DBC *dbcp; - /* Initialize the key/data pair so the flags aren't set. */ - xzero (keydatum); - xzero (valdatum); status = dbp->cursor (dbp, NULL, &dbcp); for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); @@ -517,7 +515,7 @@ berkdb_map (struct Lisp_Database *db, Lisp_Object func) } static void -berkdb_close (struct Lisp_Database *db) +berkdb_close (Lisp_Database *db) { if (db->db_handle) { @@ -571,7 +569,7 @@ and defaults to 0755. /* This function can GC */ int modemask; int accessmask = 0; - struct Lisp_Database *db = NULL; + Lisp_Database *db = NULL; char *filename; struct gcpro gcpro1, gcpro2; @@ -579,7 +577,8 @@ and defaults to 0755. GCPRO2 (file, access_); file = Fexpand_file_name (file, Qnil); UNGCPRO; - filename = (char *) XSTRING_DATA (file); + + GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename); if (NILP (access_)) { @@ -622,7 +621,6 @@ and defaults to 0755. db = allocate_database (); db->dbm_handle = dbase; - db->type = DB_DBM; db->funcs = &ndbm_func_block; goto db_done; } @@ -676,7 +674,6 @@ and defaults to 0755. db = allocate_database (); db->db_handle = dbase; - db->type = DB_BERKELEY; db->funcs = &berk_func_block; goto db_done; } @@ -709,7 +706,7 @@ replace any existing entry in the database. CHECK_STRING (key); CHECK_STRING (value); { - struct Lisp_Database *db = XDATABASE (database); + Lisp_Database *db = XDATABASE (database); int status = db->funcs->put (db, key, value, replace); return status ? Qt : Qnil; } @@ -723,7 +720,7 @@ Remove KEY from DATABASE. CHECK_LIVE_DATABASE (database); CHECK_STRING (key); { - struct Lisp_Database *db = XDATABASE (database); + Lisp_Database *db = XDATABASE (database); int status = db->funcs->rem (db, key); return status ? Qt : Qnil; } @@ -738,7 +735,7 @@ If there is no corresponding value, return DEFAULT (defaults to nil). CHECK_LIVE_DATABASE (database); CHECK_STRING (key); { - struct Lisp_Database *db = XDATABASE (database); + Lisp_Database *db = XDATABASE (database); Lisp_Object retval = db->funcs->get (db, key); return NILP (retval) ? default_ : retval; } @@ -795,4 +792,13 @@ vars_of_database (void) #ifdef HAVE_BERKELEY_DB Fprovide (Qberkeley_db); #endif + +#if 0 /* #### implement me! */ +#ifdef MULE + DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /* +Coding system used to convert data in database files. +*/ ); + Vdatabase_coding_system = Qnil; +#endif +#endif /* 0 */ } diff --git a/src/debug.c b/src/debug.c index 28f25f1..d3eb58d 100644 --- a/src/debug.c +++ b/src/debug.c @@ -59,10 +59,10 @@ enum debug_loop static Lisp_Object xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type) { - int flag = ((op == ADD) ? 1 : 0); + int flag = (op == ADD) ? 1 : 0; Lisp_Object retval = Qnil; -#define FROB(item)\ +#define FROB(item) \ if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item)) \ { \ if (op == ADD || op == DELETE || op == INIT) \ @@ -75,7 +75,7 @@ xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type) else if (op == SETTYPE) \ active_debug_classes.types_of_##item = XINT (type); \ else if (op == TYPE) \ - retval = make_int (active_debug_classes.types_of_##item), Qnil; \ + retval = make_int (active_debug_classes.types_of_##item); \ if (op == INIT) active_debug_classes.types_of_##item = VALBITS; \ } diff --git a/src/depend b/src/depend index f1fefdc..419ee1d 100644 --- a/src/depend +++ b/src/depend @@ -24,21 +24,21 @@ toolbar-msw.o: $(LISP_H) buffer.h bufslots.h conslots.h console-msw.h console.h #ifdef HAVE_X_WINDOWS balloon-x.o: $(LISP_H) balloon_help.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h xintrinsic.h console-x.o: $(LISP_H) conslots.h console-x.h console.h lisp-disunion.h lisp-union.h lrecord.h process.h redisplay.h symeval.h symsinit.h xintrinsic.h -device-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmu.h -dialog-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h EmacsShell.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h +device-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h elhash.h events.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmu.h +dialog-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h frame-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h EmacsShell.h ExternalShell.h buffer.h bufslots.h conslots.h console-x.h console.h device.h dragdrop.h events-mod.h events.h extents.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h xintrinsicp.h xmprimitivep.h xmu.h glyphs-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h bitmaps.h buffer.h bufslots.h conslots.h console-x.h console.h device.h file-coding.h frame.h frameslots.h glyphs-x.h glyphs.h imgproc.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h xintrinsic.h xmu.h gui-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h xintrinsic.h input-method-xfs.o: $(LISP_H) EmacsFrame.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h input-method-xlib.o: $(LISP_H) EmacsFrame.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h -menubar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h EmacsShell.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h +menubar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h objects-x.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h specifier.h symeval.h symsinit.h xintrinsic.h redisplay-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h conslots.h console-x.h console.h debug.h device.h faces.h file-coding.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-ccl.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysproc.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmprimitivep.h -scrollbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h conslots.h console-x.h console.h device.h frame.h frameslots.h glyphs-x.h glyphs.h gui-x.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h -toolbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h buffer.h bufslots.h conslots.h console-x.h console.h device.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmprimitivep.h +scrollbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h conslots.h console-x.h console.h device.h frame.h frameslots.h glyphs-x.h glyphs.h gui-x.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h +toolbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h conslots.h console-x.h console.h device.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h xintrinsicp.h xmprimitivep.h #endif #ifdef HAVE_DATABASE -database.o: $(LISP_H) database.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h +database.o: $(LISP_H) buffer.h bufslots.h database.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfile.h #endif #ifdef MULE mule-canna.o: $(LISP_H) buffer.h bufslots.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h @@ -61,65 +61,67 @@ EmacsManager.o: EmacsManager.h EmacsManagerP.h config.h xintrinsicp.h xmmanagerp EmacsShell-sub.o: EmacsShell.h EmacsShellP.h config.h xintrinsic.h xintrinsicp.h EmacsShell.o: EmacsShell.h ExternalShell.h config.h xintrinsicp.h abbrev.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h symeval.h symsinit.h syntax.h window.h winslots.h -alloc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h conslots.h console.h device.h elhash.h events.h extents.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h puresize.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h systime.h toolbar.h window.h winslots.h +alloc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h conslots.h console.h device.h elhash.h events.h extents.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h puresize-adjust.h puresize.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h systime.h toolbar.h window.h winslots.h alloca.o: config.h balloon_help.o: balloon_help.h config.h xintrinsic.h blocktype.o: $(LISP_H) blocktype.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h buffer.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syntax.h sysdep.h sysfile.h toolbar.h window.h winslots.h -bytecode.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +bytecode.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h syntax.h callint.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h events.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h symeval.h symsinit.h systime.h window.h winslots.h -callproc.o: $(LISP_H) buffer.h bufslots.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h nt.h paths.h process.h redisplay.h scrollbar.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h window.h winslots.h -casefiddle.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +callproc.o: $(LISP_H) buffer.h bufslots.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h nt.h process.h redisplay.h scrollbar.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h window.h winslots.h +casefiddle.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h casetab.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h -chartab.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +chartab.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h cm.o: $(LISP_H) conslots.h console-tty.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h -cmdloop.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h macros.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h +cmdloop.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h cmds.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h console-stream.o: $(LISP_H) conslots.h console-stream.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h -console-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h faces.h file-coding.h frame.h frameslots.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systty.h toolbar.h +console-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h faces.h file-coding.h frame.h frameslots.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systty.h toolbar.h console.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h data.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfloat.h syssignal.h debug.o: $(LISP_H) bytecode.h debug.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h device-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h events.h faces.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h device.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h events.h faces.h frame.h frameslots.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h toolbar.h window.h winslots.h +dgif_lib.o: gifrlib.h dialog.o: $(LISP_H) conslots.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h -dired.o: $(LISP_H) buffer.h bufslots.h commands.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h opaque.h regex.h symeval.h symsinit.h sysdir.h sysfile.h +dired.o: $(LISP_H) buffer.h bufslots.h commands.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h opaque.h regex.h symeval.h symsinit.h sysdir.h sysfile.h syspwd.h systime.h dll.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysdll.h doc.o: $(LISP_H) buffer.h bufslots.h bytecode.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfile.h doprnt.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h dragdrop.o: $(LISP_H) dragdrop.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h dynarr.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h ecrt0.o: config.h -editfns.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syspwd.h systime.h toolbar.h window.h winslots.h +editfns.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syspwd.h systime.h toolbar.h window.h winslots.h eldap.o: $(LISP_H) eldap.h lisp-disunion.h lisp-union.h lrecord.h opaque.h symeval.h symsinit.h sysdep.h -elhash.o: $(LISP_H) bytecode.h elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -emacs.o: $(LISP_H) backtrace.h buffer.h bufslots.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h paths.h process.h symeval.h symsinit.h sysdep.h sysdll.h sysfile.h syssignal.h systime.h systty.h +elhash.o: $(LISP_H) bytecode.h elhash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h +emacs.o: $(LISP_H) backtrace.h buffer.h bufslots.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h paths.h process.h redisplay.h symeval.h symsinit.h sysdep.h sysdll.h sysfile.h syssignal.h systime.h systty.h eval.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h -event-Xt.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h blocktype.h buffer.h bufslots.h commands.h conslots.h console-tty.h console-x.h console.h device.h dragdrop.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h offix-types.h offix.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h toolbar.h xintrinsic.h xintrinsicp.h +event-Xt.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h blocktype.h buffer.h bufslots.h conslots.h console-tty.h console-x.h console.h device.h dragdrop.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h offix-types.h offix.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h toolbar.h xintrinsic.h xintrinsicp.h event-stream.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h blocktype.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h gui-x.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h lstream.h macros.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systime.h toolbar.h window.h winslots.h xintrinsic.h event-tty.o: $(LISP_H) conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h process.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h event-unixoid.o: $(LISP_H) conslots.h console-stream.h console-tty.h console.h device.h events.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h process.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h events.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console-x.h console.h device.h events-mod.h events.h extents.h frame.h frameslots.h glyphs.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h xintrinsic.h -extents.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h hash.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h -faces.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h hash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h +extents.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h +faces.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h file-coding.o: $(LISP_H) buffer.h bufslots.h elhash.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-ccl.h mule-charset.h symeval.h symsinit.h fileio.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h ndir.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysdir.h sysfile.h sysproc.h syspwd.h systime.h toolbar.h window.h winslots.h filelock.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h paths.h symeval.h symsinit.h sysdir.h sysfile.h syspwd.h syssignal.h filemode.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h floatfns.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfloat.h syssignal.h -fns.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h +fns.o: $(LISP_H) buffer.h bufslots.h bytecode.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h font-lock.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h frame-tty.o: $(LISP_H) conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systime.h systty.h toolbar.h -frame.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h extents.h faces.h frame.h frameslots.h glyphs.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h systime.h toolbar.h window.h winslots.h +frame.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h extents.h faces.h frame.h frameslots.h glyphs.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h free-hook.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h general.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h getloadavg.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h -glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h file-coding.h frame.h frameslots.h glyphs.h imgproc.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h +gif_io.o: gifrlib.h +glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h file-coding.h frame.h frameslots.h gifrlib.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h glyphs.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h faces.h frame.h frameslots.h glyphs.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h gmalloc.o: config.h getpagesize.h gpmevent.o: $(LISP_H) conslots.h console-tty.h console.h device.h events-mod.h events.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h gui.o: $(LISP_H) bytecode.h gui.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -hash.o: $(LISP_H) elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h +hash.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h hftctl.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h hpplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h imgproc.o: $(LISP_H) imgproc.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h @@ -128,11 +130,11 @@ inline.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h bytecode.h chart input-method-motif.o: $(LISP_H) EmacsFrame.h conslots.h console-x.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h xintrinsic.h insdel.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h intl.o: $(LISP_H) bytecode.h conslots.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -keymap.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h conslots.h console.h device.h elhash.h events-mod.h events.h frame.h frameslots.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h +keymap.o: $(LISP_H) buffer.h bufslots.h bytecode.h conslots.h console.h device.h elhash.h events-mod.h events.h frame.h frameslots.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h libsst.o: $(LISP_H) libsst.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -line-number.o: $(LISP_H) buffer.h bufslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h +line-number.o: $(LISP_H) buffer.h bufslots.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h linuxplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h syssignal.h -lread.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h paths.h symeval.h symsinit.h sysfile.h sysfloat.h +lread.o: $(LISP_H) buffer.h bufslots.h bytecode.h elhash.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h symeval.h symsinit.h sysfile.h sysfloat.h lstream.o: $(LISP_H) buffer.h bufslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h sysfile.h macros.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h keymap.h lisp-disunion.h lisp-union.h lrecord.h macros.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h malloc.o: config.h getpagesize.h @@ -140,7 +142,7 @@ marker.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h m md5.o: $(LISP_H) buffer.h bufslots.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h menubar.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h frame.h frameslots.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h minibuf.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-stream.h console.h device.h events.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h -nas.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h +nas.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h nt.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h nt.h ntheap.h symeval.h symsinit.h sysproc.h syssignal.h systime.h ntheap.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h ntheap.h symeval.h symsinit.h ntplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h @@ -151,23 +153,23 @@ offix.o: offix-cursors.h offix-types.h offix.h xintrinsic.h opaque.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h opaque.h symeval.h symsinit.h print.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h conslots.h console-stream.h console-tty.h console.h device.h extents.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h syssignal.h systty.h toolbar.h process-nt.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h process.h procimpl.h symeval.h symsinit.h sysdep.h -process-unix.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h -process.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h -profile.o: $(LISP_H) backtrace.h bytecode.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h systime.h +process-unix.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h +process.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h +profile.o: $(LISP_H) backtrace.h bytecode.h elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h systime.h pure.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h puresize-adjust.h puresize.h symeval.h symsinit.h ralloc.o: $(LISP_H) getpagesize.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h rangetab.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h rangetab.h symeval.h symsinit.h realpath.o: config.h -redisplay-output.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h toolbar.h window.h winslots.h +redisplay-output.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h redisplay-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console.h device.h events.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-tty.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h -redisplay.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-tty.h console.h debug.h device.h extents.h faces.h file-coding.h frame.h frameslots.h glyphs.h gui.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h objects.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h window.h winslots.h +redisplay.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-tty.h console.h debug.h device.h elhash.h extents.h faces.h file-coding.h frame.h frameslots.h glyphs.h gui.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h objects.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h window.h winslots.h regex.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h regex.h symeval.h symsinit.h syntax.h scrollbar.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h -search.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h regex.h symeval.h symsinit.h syntax.h +search.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h regex.h symeval.h symsinit.h syntax.h sgiplay.o: $(LISP_H) libst.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sheap.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h sheap-adjust.h symeval.h symsinit.h signal.o: $(LISP_H) conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h toolbar.h -sound.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h symeval.h symsinit.h sysdep.h xintrinsic.h +sound.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h symeval.h symsinit.h sysdep.h xintrinsic.h specifier.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h strcat.o: config.h strcmp.o: config.h @@ -177,7 +179,7 @@ sunOS-fix.o: config.h sunplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h sunpro.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h symbols.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h -syntax.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +syntax.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h sysdep.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h ntheap.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysdir.h sysfile.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h sysdll.o: config.h sysdll.h termcap.o: $(LISP_H) conslots.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h @@ -199,11 +201,11 @@ unexfreebsd.o: config.h unexhp9k3.o: config.h sysdep.h unexhp9k800.o: config.h unexmips.o: config.h getpagesize.h -unexnt.o: ntheap.h +unexnt.o: config.h ntheap.h unexsunos4.o: config.h vm-limit.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h mem-limits.h symeval.h symsinit.h -widget.o: $(LISP_H) buffer.h bufslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h -window.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h +widget.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h +window.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xgccache.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h xgccache.h xmu.o: config.h xselect.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h xintrinsic.h diff --git a/src/device-msw.c b/src/device-msw.c index 2b8e28e..6c81ef8 100644 --- a/src/device-msw.c +++ b/src/device-msw.c @@ -159,7 +159,7 @@ mswindows_init_device (struct device *d, Lisp_Object props) static void mswindows_finish_init_device (struct device *d, Lisp_Object props) { - /* Initialise DDE management library and our related globals. We execute a + /* Initialize DDE management library and our related globals. We execute a * dde Open("file") by simulating a drop, so this depends on dnd support. */ #ifdef HAVE_DRAGNDROP mswindows_dde_mlid = 0; diff --git a/src/device-x.c b/src/device-x.c index b0cad36..ff63865 100644 --- a/src/device-x.c +++ b/src/device-x.c @@ -39,6 +39,7 @@ Boston, MA 02111-1307, USA. */ #include "objects-x.h" #include "buffer.h" +#include "elhash.h" #include "events.h" #include "faces.h" #include "frame.h" @@ -328,8 +329,6 @@ x_init_device (struct device *d, Lisp_Object props) CONST char *app_class; CONST char *app_name; CONST char *disp_name; - Arg xargs[6]; - Cardinal numargs; Visual *visual = NULL; int depth = 8; /* shut up the compiler */ Colormap cmap; @@ -387,7 +386,7 @@ x_init_device (struct device *d, Lisp_Object props) XtNumber (emacs_options), &argc, argv); speed_up_interrupts (); - screen = DefaultScreen(dpy); + screen = DefaultScreen (dpy); if (NILP (Vdefault_x_device)) Vdefault_x_device = device; @@ -400,7 +399,7 @@ x_init_device (struct device *d, Lisp_Object props) does not override resources defined elsewhere */ CONST char *data_dir; char *path; - XrmDatabase db = XtDatabase (dpy); /* ### XtScreenDatabase(dpy) ? */ + XrmDatabase db = XtDatabase (dpy); /* #### XtScreenDatabase(dpy) ? */ CONST char *locale = XrmLocaleOfDatabase (db); if (STRINGP (Vx_app_defaults_directory) && @@ -434,9 +433,8 @@ x_init_device (struct device *d, Lisp_Object props) XtGetApplicationNameAndClass (dpy, (char **) &app_name, (char **) &app_class); /* search for a matching visual if requested by the user, or setup the display default */ - numargs = 0; { - char *buf1 = (char *)alloca (strlen (app_name) + 17); + char *buf1 = (char *)alloca (strlen (app_name) + 17); char *buf2 = (char *)alloca (strlen (app_class) + 17); char *type; XrmValue value; @@ -445,85 +443,98 @@ x_init_device (struct device *d, Lisp_Object props) sprintf (buf2, "%s.EmacsVisual", app_class); if (XrmGetResource (XtDatabase (dpy), buf1, buf2, &type, &value) == True) { - int cnt = 0, vis_class= PseudoColor; + int cnt = 0, vis_class = PseudoColor; XVisualInfo vinfo; char *res, *str = (char*)value.addr; - if (strncmp(str, "StaticGray", 10) == 0) cnt = 10, vis_class = StaticGray; - else if (strncmp(str, "StaticColor", 11) == 0) cnt = 11, vis_class = StaticColor; - else if (strncmp(str, "TrueColor", 9) == 0) cnt = 9, vis_class = TrueColor; - else if (strncmp(str, "GrayScale", 9) == 0) cnt = 9, vis_class = GrayScale; - else if (strncmp(str, "PseudoColor", 11) == 0) cnt = 11, vis_class = PseudoColor; - else if (strncmp(str, "DirectColor", 11) == 0) cnt = 11, vis_class = DirectColor; +#define CHECK_VIS_CLASS(class) \ + else if (strncmp (str, #class, sizeof (#class) - 1) == 0) \ + cnt = sizeof (#class) - 1, vis_class = class + + if (1) + ; + CHECK_VIS_CLASS (StaticGray); + CHECK_VIS_CLASS (StaticColor); + CHECK_VIS_CLASS (TrueColor); + CHECK_VIS_CLASS (GrayScale); + CHECK_VIS_CLASS (PseudoColor); + CHECK_VIS_CLASS (DirectColor); + if (cnt) { res = str + cnt; - depth = atoi(res); + depth = atoi (res); if (depth == 0) { - stderr_out("Invalid Depth specification in %s... ignoring...\n",(char*)str); + stderr_out ("Invalid Depth specification in %s... ignoring...\n", str); } else { - if (XMatchVisualInfo(dpy, screen, depth, vis_class, &vinfo)) + if (XMatchVisualInfo (dpy, screen, depth, vis_class, &vinfo)) { visual = vinfo.visual; } else { - stderr_out("Can't match the requested visual %s... using defaults\n",str); + stderr_out ("Can't match the requested visual %s... using defaults\n", str); } } } else { - stderr_out("Invalid Visual specification in %s... ignoring.\n",(char*)str); + stderr_out( "Invalid Visual specification in %s... ignoring.\n", str); } } if (visual == NULL) { - visual = DefaultVisual(dpy, screen); - depth = DefaultDepth(dpy, screen); + visual = DefaultVisual (dpy, screen); + depth = DefaultDepth (dpy, screen); } /* If we've got the same visual as the default and it's PseudoColor, check to see if the user specified that we need a private colormap */ - if (visual == DefaultVisual(dpy, screen)) + if (visual == DefaultVisual (dpy, screen)) { sprintf (buf1, "%s.privateColormap", app_name); sprintf (buf2, "%s.PrivateColormap", app_class); if ((visual->class == PseudoColor) && (XrmGetResource (XtDatabase (dpy), buf1, buf2, &type, &value) == True)) { - cmap = XCopyColormapAndFree(dpy, DefaultColormap(dpy, screen)); + cmap = XCopyColormapAndFree (dpy, DefaultColormap (dpy, screen)); } else { - cmap = DefaultColormap(dpy, screen); + cmap = DefaultColormap (dpy, screen); } } else { /* We have to create a matching colormap anyway... ### think about using standard colormaps (need the Xmu libs?) */ - cmap = XCreateColormap(dpy, RootWindow(dpy, screen), visual, AllocNone); - XInstallColormap(dpy, cmap); + cmap = XCreateColormap (dpy, RootWindow(dpy, screen), visual, AllocNone); + XInstallColormap (dpy, cmap); } } - XtSetArg(xargs[numargs],XtNvisual, visual); numargs++; - XtSetArg(xargs[numargs],XtNdepth, depth); numargs++; - XtSetArg(xargs[numargs],XtNcolormap, cmap); numargs++; - DEVICE_X_VISUAL (d) = visual; - DEVICE_X_COLORMAP (d) = cmap; - DEVICE_X_DEPTH (d) = depth; + DEVICE_X_VISUAL (d) = visual; + DEVICE_X_COLORMAP (d) = cmap; + DEVICE_X_DEPTH (d) = depth; validify_resource_component ((char *) XSTRING_DATA (DEVICE_NAME (d)), XSTRING_LENGTH (DEVICE_NAME (d))); - app_shell = XtAppCreateShell (NULL, app_class, - applicationShellWidgetClass, - dpy, xargs, numargs); + + { + Arg al[3]; + XtSetArg (al[0], XtNvisual, visual); + XtSetArg (al[1], XtNdepth, depth); + XtSetArg (al[2], XtNcolormap, cmap); + + app_shell = XtAppCreateShell (NULL, app_class, + applicationShellWidgetClass, + dpy, al, countof (al)); + } DEVICE_XT_APP_SHELL (d) = app_shell; + #ifdef HAVE_XIM XIM_init_device(d); #endif /* HAVE_XIM */ @@ -531,19 +542,16 @@ x_init_device (struct device *d, Lisp_Object props) /* Realize the app_shell so that its window exists for GC creation purposes, and set it to the size of the root window for child placement purposes */ { - Screen *scrn = ScreenOfDisplay(dpy, screen); - int screen_width, screen_height; - screen_width = WidthOfScreen(scrn); - screen_height = HeightOfScreen(scrn); - numargs = 0; - XtSetArg (xargs[numargs], XtNmappedWhenManaged, False); numargs++; - XtSetArg (xargs[numargs], XtNx, 0); numargs++; - XtSetArg (xargs[numargs], XtNy, 0); numargs++; - XtSetArg (xargs[numargs], XtNwidth, screen_width); numargs++; - XtSetArg (xargs[numargs], XtNheight, screen_height); numargs++; - XtSetValues (app_shell, xargs, numargs); + Arg al[5]; + XtSetArg (al[0], XtNmappedWhenManaged, False); + XtSetArg (al[1], XtNx, 0); + XtSetArg (al[2], XtNy, 0); + XtSetArg (al[3], XtNwidth, WidthOfScreen (ScreenOfDisplay (dpy, screen))); + XtSetArg (al[4], XtNheight, HeightOfScreen (ScreenOfDisplay (dpy, screen))); + XtSetValues (app_shell, al, countof (al)); XtRealizeWidget (app_shell); } + #ifdef HAVE_SESSION { int new_argc; @@ -593,8 +601,8 @@ x_finish_init_device (struct device *d, Lisp_Object props) static void x_mark_device (struct device *d, void (*markobj) (Lisp_Object)) { - ((markobj) (DEVICE_X_WM_COMMAND_FRAME (d))); - ((markobj) (DEVICE_X_DATA (d)->x_keysym_map_hashtable)); + markobj (DEVICE_X_WM_COMMAND_FRAME (d)); + markobj (DEVICE_X_DATA (d)->x_keysym_map_hash_table); } @@ -637,6 +645,12 @@ x_delete_device (struct device *d) if (DEVICE_X_DATA (d)->x_keysym_map) XFree ((char *) DEVICE_X_DATA (d)->x_keysym_map); + if (DEVICE_XT_APP_SHELL (d)) + { + XtDestroyWidget (DEVICE_XT_APP_SHELL (d)); + DEVICE_XT_APP_SHELL (d) = NULL; + } + XtCloseDisplay (display); DEVICE_X_DISPLAY (d) = 0; #ifdef FREE_CHECKING @@ -915,7 +929,7 @@ x_IO_error_handler (Display *disp) DEVICE_X_BEING_DELETED (d) = 1; Fthrow (Qtop_level, Qnil); - RETURN_NOT_REACHED (0); + return 0; /* not reached */ } DEFUN ("x-debug-mode", Fx_debug_mode, 1, 2, 0, /* @@ -1448,8 +1462,8 @@ Valid keysyms are listed in the files /usr/include/X11/keysymdef.h and in return XStringToKeysym (keysym_ext) ? Qt : Qnil; } -DEFUN ("x-keysym-hashtable", Fx_keysym_hashtable, 0, 1, 0, /* -Return a hashtable which contains a hash key for all keysyms which +DEFUN ("x-keysym-hash-table", Fx_keysym_hash_table, 0, 1, 0, /* +Return a hash table which contains a hash key for all keysyms which name keys on the keyboard. See `x-keysym-on-keyboard-p'. */ (device)) @@ -1458,7 +1472,7 @@ name keys on the keyboard. See `x-keysym-on-keyboard-p'. if (!DEVICE_X_P (d)) signal_simple_error ("Not an X device", device); - return DEVICE_X_DATA (d)->x_keysym_map_hashtable; + return DEVICE_X_DATA (d)->x_keysym_map_hash_table; } DEFUN ("x-keysym-on-keyboard-sans-modifiers-p", Fx_keysym_on_keyboard_sans_modifiers_p, @@ -1480,7 +1494,7 @@ The two names differ in capitalization and underscoring. signal_simple_error ("Not an X device", device); return (EQ (Qsans_modifiers, - Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASHTABLE (d), Qnil)) ? + Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASH_TABLE (d), Qnil)) ? Qt : Qnil); } @@ -1502,7 +1516,7 @@ The two names differ in capitalization and underscoring. if (!DEVICE_X_P (d)) signal_simple_error ("Not an X device", device); - return (NILP (Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASHTABLE (d), Qnil)) ? + return (NILP (Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASH_TABLE (d), Qnil)) ? Qnil : Qt); } @@ -1654,7 +1668,7 @@ syms_of_device_x (void) DEFSUBR (Fx_server_vendor); DEFSUBR (Fx_server_version); DEFSUBR (Fx_valid_keysym_name_p); - DEFSUBR (Fx_keysym_hashtable); + DEFSUBR (Fx_keysym_hash_table); DEFSUBR (Fx_keysym_on_keyboard_p); DEFSUBR (Fx_keysym_on_keyboard_sans_modifiers_p); diff --git a/src/device.c b/src/device.c index 44d69ba..de3c8df 100644 --- a/src/device.c +++ b/src/device.c @@ -37,11 +37,14 @@ Boston, MA 02111-1307, USA. */ #include "frame.h" #include "keymap.h" #include "redisplay.h" -#include "scrollbar.h" #include "specifier.h" #include "sysdep.h" #include "window.h" +#ifdef HAVE_SCROLLBARS +#include "scrollbar.h" +#endif + #include "syssignal.h" /* Vdefault_device is the firstly-created non-stream device that's still @@ -82,29 +85,29 @@ mark_device (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct device *d = XDEVICE (obj); - ((markobj) (d->name)); - ((markobj) (d->connection)); - ((markobj) (d->canon_connection)); - ((markobj) (d->console)); - ((markobj) (d->_selected_frame)); - ((markobj) (d->frame_with_focus_real)); - ((markobj) (d->frame_with_focus_for_hooks)); - ((markobj) (d->frame_that_ought_to_have_focus)); - ((markobj) (d->device_class)); - ((markobj) (d->user_defined_tags)); - ((markobj) (d->pixel_to_glyph_cache.obj1)); - ((markobj) (d->pixel_to_glyph_cache.obj2)); - - ((markobj) (d->color_instance_cache)); - ((markobj) (d->font_instance_cache)); + markobj (d->name); + markobj (d->connection); + markobj (d->canon_connection); + markobj (d->console); + markobj (d->selected_frame); + markobj (d->frame_with_focus_real); + markobj (d->frame_with_focus_for_hooks); + markobj (d->frame_that_ought_to_have_focus); + markobj (d->device_class); + markobj (d->user_defined_tags); + markobj (d->pixel_to_glyph_cache.obj1); + markobj (d->pixel_to_glyph_cache.obj2); + + markobj (d->color_instance_cache); + markobj (d->font_instance_cache); #ifdef MULE - ((markobj) (d->charset_font_cache)); + markobj (d->charset_font_cache); #endif - ((markobj) (d->image_instance_cache)); + markobj (d->image_instance_cache); if (d->devmeths) { - ((markobj) (d->devmeths->symbol)); + markobj (d->devmeths->symbol); MAYBE_DEVMETH (d, mark_device, (d, markobj)); } @@ -177,7 +180,7 @@ allocate_device (Lisp_Object console) d->connection = Qnil; d->canon_connection = Qnil; d->frame_list = Qnil; - d->_selected_frame = Qnil; + d->selected_frame = Qnil; d->frame_with_focus_real = Qnil; d->frame_with_focus_for_hooks = Qnil; d->frame_that_ought_to_have_focus = Qnil; @@ -189,22 +192,22 @@ allocate_device (Lisp_Object console) d->infd = d->outfd = -1; /* #### is 20 reasonable? */ - d->color_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQUAL); - d->font_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQUAL); + d->color_instance_cache = + make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL); + d->font_instance_cache = + make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL); #ifdef MULE /* Note that the following table is bi-level. */ - d->charset_font_cache = make_lisp_hashtable (20, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + d->charset_font_cache = + make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); #endif /* Note that the image instance cache is actually bi-level. See device.h. We use a low number here because most of the - time there aren't very many diferent masks that will be used. + time there aren't very many different masks that will be used. */ - d->image_instance_cache = make_lisp_hashtable (5, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + d->image_instance_cache = + make_lisp_hash_table (5, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); UNGCPRO; return d; @@ -216,7 +219,7 @@ decode_device (Lisp_Object device) if (NILP (device)) device = Fselected_device (Qnil); /* quietly accept frames for the device arg */ - if (FRAMEP (device)) + else if (FRAMEP (device)) device = FRAME_DEVICE (decode_frame (device)); CHECK_LIVE_DEVICE (device); return XDEVICE (device); @@ -287,7 +290,7 @@ set_device_selected_frame (struct device *d, Lisp_Object frame) { if (!NILP (frame) && !FRAME_MINIBUF_ONLY_P (XFRAME (frame))) set_console_last_nonminibuf_frame (XCONSOLE (DEVICE_CONSOLE (d)), frame); - d->_selected_frame = frame; + d->selected_frame = frame; } DEFUN ("set-device-selected-frame", Fset_device_selected_frame, 2, 2, 0, /* @@ -914,7 +917,7 @@ Get a metric for DEVICE as provided by the system. METRIC must be a symbol specifying requested metric. Note that the metrics returned are these provided by the system internally, not read from resources, -so obtained from the most internal level. +so obtained from the most internal level. If a metric is not provided by the system, then DEFAULT is returned. @@ -923,14 +926,14 @@ When DEVICE is nil, selected device is assumed Metrics, by group, are: COLORS. Colors are returned as valid color instantiators. No other assumption -on the returned valie should be made (i.e. it can be a string on one system but +on the returned value should be made (i.e. it can be a string on one system but a color instance on another). For colors, returned value is a cons of foreground and background colors. Note that if the system provides only one color of the pair, the second one may be nil. color-default Standard window text foreground and background. -color-select Selection highligh text and backgroun colors. -color-balloon Ballon popup text and background colors. +color-select Selection highlight text and background colors. +color-balloon Balloon popup text and background colors. color-3d-face 3-D object (button, modeline) text and surface colors. color-3d-light Fore and back colors for 3-D edges facing light source. color-3d-dark Fore and back colors for 3-D edges facing away from @@ -954,7 +957,7 @@ font-dialog Dialog boxes font GEOMETRY. These metrics are returned as conses of (X . Y). As with colors, either car or cdr of the cons may be nil if the system does not provide one -of corresponding dimensions. +of the corresponding dimensions. size-cursor Mouse cursor size. size-scrollbar Scrollbars (WIDTH . HEIGHT) @@ -971,14 +974,14 @@ size-workspace Workspace size in pixels. This can be less than the windows. size-device-mm Device screen size in millimeters. device-dpi Device resolution, in dots per inch. -num-bit-planes Integer, number of deivce bit planes. +num-bit-planes Integer, number of device bit planes. num-color-cells Integer, number of device color cells. FEATURES. This group reports various device features. If a feature is present, integer 1 (one) is returned, if it is not present, then integer 0 (zero) is returned. If the system is unaware of the feature, then DEFAULT is returned. - + mouse-buttons Integer, number of mouse buttons, or zero if no mouse. swap-buttons Non-zero if left and right mouse buttons are swapped. show-sounds User preference for visual over audible bell. diff --git a/src/device.h b/src/device.h index 139809f..9b52dff 100644 --- a/src/device.h +++ b/src/device.h @@ -100,7 +100,7 @@ struct device frames on this device have the window-system focus), but selected_frame will never be nil if there are any frames on the device. */ - Lisp_Object _selected_frame; + Lisp_Object selected_frame; /* Frame that currently contains the window-manager focus, or none. Note that we've split frame_with_focus into two variables. frame_with_focus_real is the value we use most of the time, @@ -308,7 +308,7 @@ int valid_device_class_p (Lisp_Object class); #define DEVICE_NAME(d) ((d)->name) #define DEVICE_CLASS(d) ((d)->device_class) /* Catch people attempting to set this. */ -#define DEVICE_SELECTED_FRAME(d) NON_LVALUE ((d)->_selected_frame) +#define DEVICE_SELECTED_FRAME(d) NON_LVALUE ((d)->selected_frame) #define DEVICE_FRAME_WITH_FOCUS_REAL(d) ((d)->frame_with_focus_real) #define DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS(d) ((d)->frame_with_focus_for_hooks) #define DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS(d) \ @@ -331,11 +331,11 @@ int valid_device_class_p (Lisp_Object class); #define INVALIDATE_DEVICE_PIXEL_TO_GLYPH_CACHE(d) \ ((void) ((d)->pixel_to_glyph_cache.valid = 0)) -#define INVALIDATE_PIXEL_TO_GLYPH_CACHE do { \ - Lisp_Object _devcons_, _concons_; \ - DEVICE_LOOP_NO_BREAK (_devcons_, _concons_) \ - INVALIDATE_DEVICE_PIXEL_TO_GLYPH_CACHE (XDEVICE (XCAR (_devcons_)));\ - } while (0) +#define INVALIDATE_PIXEL_TO_GLYPH_CACHE do { \ + Lisp_Object IPTGC_devcons, IPTGC_concons; \ + DEVICE_LOOP_NO_BREAK (IPTGC_devcons, IPTGC_concons) \ + INVALIDATE_DEVICE_PIXEL_TO_GLYPH_CACHE (XDEVICE (XCAR (IPTGC_devcons))); \ +} while (0) #define MARK_DEVICE_FACES_CHANGED(d) \ ((void) (faces_changed = (d)->faces_changed = 1)) diff --git a/src/dgif_lib.c b/src/dgif_lib.c index 2ecab3f..b53b85e 100644 --- a/src/dgif_lib.c +++ b/src/dgif_lib.c @@ -112,7 +112,7 @@ void DGifInitRead(GifFileType *GifFile) Buf[GIF_STAMP_LEN] = 0; if (strncmp(GIF_STAMP, (const char *) Buf, GIF_VERSION_POS) != 0) { GifInternError(GifFile, D_GIF_ERR_NOT_GIF_FILE); - } + } DGifGetScreenDesc(GifFile); } @@ -249,7 +249,7 @@ void DGifGetImageDesc(GifFileType *GifFile) MakeMapObject (GifFile->Image.ColorMap->ColorCount, GifFile->Image.ColorMap->Colors); } - sp->RasterBits = (GifPixelType *)NULL; + sp->RasterBits = NULL; sp->ExtensionBlockCount = 0; sp->ExtensionBlocks = (ExtensionBlock *)NULL; } @@ -745,7 +745,7 @@ void DGifSlurp(GifFileType *GifFile) ImageSize = sp->ImageDesc.Width * sp->ImageDesc.Height; sp->RasterBits - = (GifPixelType*) malloc(ImageSize * sizeof(GifPixelType)); + = (GifPixelType*) malloc (ImageSize * sizeof(GifPixelType)); DGifGetLine(GifFile, sp->RasterBits, ImageSize); break; @@ -856,7 +856,7 @@ SavedImage *MakeSavedImage(GifFileType *GifFile, SavedImage *CopyFrom) CopyFrom->ImageDesc.ColorMap->Colors); /* next, the raster */ - sp->RasterBits = (GifPixelType*)malloc(sizeof(GifPixelType) + sp->RasterBits = (GifPixelType *) malloc(sizeof(GifPixelType) * CopyFrom->ImageDesc.Height * CopyFrom->ImageDesc.Width); memcpy(sp->RasterBits, @@ -911,7 +911,7 @@ void FreeSavedImages(GifFileType *GifFile) * Miscellaneous utility functions * ******************************************************************************/ -int BitSize(int n) +static int BitSize(int n) /* return smallest bitfield size n will fit in */ { register int i; diff --git a/src/dialog-msw.c b/src/dialog-msw.c index 75c8443..24c272c 100644 --- a/src/dialog-msw.c +++ b/src/dialog-msw.c @@ -20,7 +20,7 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ -/* Autorship: +/* Author: Initially written by kkm, May 1998 */ @@ -46,9 +46,9 @@ static Lisp_Object Vdialog_data_list; Button metrics -------------- All buttons have height of 15 DLU. The minimum width for a button is 32 DLU, - but it can be expanded to accomodate its text, so the width is calculated as + but it can be expanded to accommodate its text, so the width is calculated as 8 DLU per button plus 4 DLU per character. - max (32, 6 * text_lenght). The factor of six is rather empirical, but it + max (32, 6 * text_length). The factor of six is rather empirical, but it works better than 8 which comes from the definition of a DLU. Buttons are spaced with 6 DLU gap. Minimum distance from the button to the left or right dialog edges is 6 DLU, and the distance between the dialog bottom edge and @@ -65,11 +65,11 @@ static Lisp_Object Vdialog_data_list; /* Text field metrics ------------------ - Text ditance from lwft and right edges is the same as for buttons, and the + Text distance from left and right edges is the same as for buttons, and the top margin is 11 DLU. The static control has height of 2 DLU per control plus 8 DLU per each line of text. Distance between the bottom edge of the control and the button row is 15 DLU. Minimum width of the static control - is 100 DLU, thus giving minmium dialog wight of 112 DLU. Maximum width is + is 100 DLU, thus giving minimum dialog weight of 112 DLU. Maximum width is 300 DLU, and, if the text is wider than that, the text is wrapped on the next line. Each character in the text is considered 4 DLU wide. */ @@ -98,13 +98,13 @@ static Lisp_Object Vdialog_data_list; Next, the width of the static field is determined. First, if all lines of text fit into max (WBR, X_MAX_TEXT), the width of the control is the same as the width of the longest line. - Sencond, if all lines of text are narrower than X_MIN_TEXT, then width of + Second, if all lines of text are narrower than X_MIN_TEXT, then width of the control is set to X_MIN_TEXT. Otherwise, width is set to max(WBR, X_AVE_TEXT). In this case, line wrapping will happen. - If width of the text contol is larger than that of the button row, then the - latter is centered accross the dialog, by giving it extra edge + If width of the text control is larger than that of the button row, then the + latter is centered across the dialog, by giving it extra edge margins. Otherwise, minimal margins are given to the button row. */ diff --git a/src/dialog-x.c b/src/dialog-x.c index 1b311dd..918b632 100644 --- a/src/dialog-x.c +++ b/src/dialog-x.c @@ -25,9 +25,7 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "console-x.h" -#include "EmacsManager.h" #include "EmacsFrame.h" -#include "EmacsShell.h" #include "gui-x.h" #include "buffer.h" diff --git a/src/dired.c b/src/dired.c index c3083cd..da7ed57 100644 --- a/src/dired.c +++ b/src/dired.c @@ -116,7 +116,7 @@ If FILES-ONLY is the symbol t, then only the "files" in the directory which might compile a new regexp until we're done with the loop! */ /* Do this opendir after anything which might signal an error. - NOTE: the above comment is old; previosly, there was no + NOTE: the above comment is old; previously, there was no unwind-protection in case of error, but now there is. */ d = opendir ((char *) XSTRING_DATA (dirname)); if (!d) @@ -128,7 +128,6 @@ If FILES-ONLY is the symbol t, then only the "files" in the directory while (1) { DIRENTRY *dp = readdir (d); - Lisp_Object name; int len; if (!dp) @@ -179,22 +178,22 @@ If FILES-ONLY is the symbol t, then only the "files" in the directory continue; } - if (!NILP (full)) - name = concat2 (dirname, make_ext_string ((Bufbyte *)dp->d_name, - len, FORMAT_FILENAME)); - else - name = make_ext_string ((Bufbyte *)dp->d_name, - len, FORMAT_FILENAME); + { + Lisp_Object name = + make_ext_string ((Bufbyte *)dp->d_name, len, FORMAT_FILENAME); + if (!NILP (full)) + name = concat2 (dirname, name); - list = Fcons (name, list); + list = Fcons (name, list); + } } } unbind_to (speccount, Qnil); /* This will close the dir */ - if (!NILP (nosort)) - RETURN_UNGCPRO (list); - else - RETURN_UNGCPRO (Fsort (Fnreverse (list), Qstring_lessp)); + if (NILP (nosort)) + list = Fsort (Fnreverse (list), Qstring_lessp); + + RETURN_UNGCPRO (list); } static Lisp_Object file_name_completion (Lisp_Object file, @@ -691,14 +690,10 @@ user_name_completion (Lisp_Object user, int all_flag, int *uniq) for (i = 0; i < user_cache_len; i++) { - Bytecount len; + Bufbyte *d_name = (Bufbyte *) user_cache[i]; + Bytecount len = strlen ((char *) d_name); /* scmp() works in chars, not bytes, so we have to compute this: */ - Charcount cclen; - Bufbyte *d_name; - - d_name = (Bufbyte *) user_cache[i]; - len = strlen (d_name); - cclen = bytecount_to_charcount (d_name, len); + Charcount cclen = bytecount_to_charcount (d_name, len); QUIT; @@ -784,8 +779,8 @@ Lisp_Object make_directory_hash_table (CONST char *path) { DIR *d; - Lisp_Object hash = make_lisp_hashtable (100, HASHTABLE_NONWEAK, - HASHTABLE_EQUAL); + Lisp_Object hash = + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); if ((d = opendir (path))) { DIRENTRY *dp; diff --git a/src/doc.c b/src/doc.c index bfa9b12..8174a02 100644 --- a/src/doc.c +++ b/src/doc.c @@ -284,10 +284,10 @@ string is passed through `substitute-command-keys'. else if (COMPILED_FUNCTIONP (fun)) { Lisp_Object tem; - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - if (! (b->flags.documentationp)) + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + if (! (f->flags.documentationp)) return Qnil; - tem = compiled_function_documentation (b); + tem = compiled_function_documentation (f); if (STRINGP (tem)) doc = tem; else if (NATNUMP (tem) || CONSP (tem)) @@ -338,7 +338,7 @@ string is passed through `substitute-command-keys'. #ifdef I18N3 Lisp_Object domain = Qnil; if (COMPILED_FUNCTIONP (fun)) - domain = Fcompiled_function_domain (fun); + domain = compiled_function_domain (XCOMPILED_FUNCTION (fun)); if (NILP (domain)) doc = Fgettext (doc); else @@ -550,7 +550,7 @@ when doc strings are referred to in the dumped Emacs. { weird_doc (sym, GETTEXT ("!CONSP(tem)"), GETTEXT ("function"), pos); - goto cont; + goto cont; } else { @@ -573,7 +573,7 @@ when doc strings are referred to in the dumped Emacs. { /* Compiled-Function objects sometimes have slots for it. */ - struct Lisp_Compiled_Function *b = + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); /* This compiled-function object must have a @@ -583,7 +583,7 @@ when doc strings are referred to in the dumped Emacs. have any doc, which is a legal if slightly bogus situation, so don't blow up. */ - if (! (b->flags.documentationp)) + if (! (f->flags.documentationp)) { weird_doc (sym, GETTEXT ("no doc slot"), GETTEXT ("bytecode"), pos); @@ -592,7 +592,7 @@ when doc strings are referred to in the dumped Emacs. else { Lisp_Object old = - compiled_function_documentation (b); + compiled_function_documentation (f); if (!ZEROP (old)) { weird_doc (sym, GETTEXT ("duplicate"), @@ -603,7 +603,7 @@ when doc strings are referred to in the dumped Emacs. if (!INTP (old)) goto weird; } - set_compiled_function_documentation (b, offset); + set_compiled_function_documentation (f, offset); } } else @@ -684,12 +684,12 @@ verify_doc_mapper (Lisp_Object sym, void *arg) } else if (COMPILED_FUNCTIONP (fun)) { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - if (! (b->flags.documentationp)) + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + if (! (f->flags.documentationp)) doc = -1; else { - Lisp_Object tem = compiled_function_documentation (b); + Lisp_Object tem = compiled_function_documentation (f); if (INTP (tem)) doc = XINT (tem); } diff --git a/src/doprnt.c b/src/doprnt.c index 5dac446..8259c5a 100644 --- a/src/doprnt.c +++ b/src/doprnt.c @@ -576,7 +576,7 @@ emacs_doprnt_1 (Lisp_Object stream, CONST Bufbyte *format_nonreloc, { Lisp_Object obj = largs[spec->argnum - 1]; if (CHARP (obj)) - CHECK_INT_COERCE_CHAR (obj); + obj = make_int (XCHAR (obj)); if (!INT_OR_FLOATP (obj)) { error ("format specifier %%%c doesn't match argument type", diff --git a/src/dynarr.c b/src/dynarr.c index 74bd399..4167b5b 100644 --- a/src/dynarr.c +++ b/src/dynarr.c @@ -44,7 +44,7 @@ until the next operation that changes the length of the array. This is a container object. Declare a dynamic array of a specific type as follows: -typdef struct +typedef struct { Dynarr_declare (mytype); } mytype_dynarr; @@ -72,7 +72,7 @@ Use the following functions/macros: The elements should be contiguous in memory, starting at BASE. Dynarr_insert_many(d, base, len, start) - Insert LEN elements to the dynamic arrary starting at position + Insert LEN elements to the dynamic array starting at position START. The elements should be contiguous in memory, starting at BASE. int Dynarr_length(d) diff --git a/src/ecrt0.c b/src/ecrt0.c index d6f1a4c..4455091 100644 --- a/src/ecrt0.c +++ b/src/ecrt0.c @@ -22,7 +22,7 @@ Boston, MA 02111-1307, USA. */ /* The standard Vax 4.2 Unix crt0.c cannot be used for Emacs - because it makes `envron' an initialized variable. + because it makes `environ' an initialized variable. It is easiest to have a special crt0.c on all machines though I don't know whether other machines actually need it. */ diff --git a/src/editfns.c b/src/editfns.c index 339b431..9bb9b8e 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -370,7 +370,7 @@ save_excursion_restore (Lisp_Object info) and cleaner never to alter the window/buffer connections. */ /* I'm certain some code somewhere depends on this behavior. --jwz */ /* Even if it did, it certainly doesn't matter anymore, because - this has been the behaviour for countless XEmacs releases + this has been the behavior for countless XEmacs releases now. --hniksic */ if (visible && (current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))) @@ -549,7 +549,6 @@ If BUFFER is nil, the current buffer is assumed. (buffer)) { struct buffer *b = decode_buffer (buffer, 1); - return beginning_of_line_p (b, BUF_PT (b)) ? Qt : Qnil; } @@ -668,7 +667,7 @@ char* user_login_name (int *uid) { struct passwd *pw = NULL; - + /* uid == NULL to return name of this user */ if (uid != NULL) { @@ -758,7 +757,7 @@ value of `user-full-name' is returned. Lisp_Object user_name; struct passwd *pw = NULL; Lisp_Object tem; - char *p, *q; + const char *p, *q; if (NILP (user) && STRINGP (Vuser_full_name)) return Vuser_full_name; @@ -833,7 +832,7 @@ get_home_directory (void) { #if defined(WINDOWSNT) && !defined(__CYGWIN32__) char *homedrive, *homepath; - + if ((homedrive = getenv("HOMEDRIVE")) != NULL && (homepath = getenv("HOMEPATH")) != NULL) { @@ -1063,14 +1062,14 @@ The number of options reflects the `strftime' function. BUG: If the charset used by the current locale is not ISO 8859-1, the characters appearing in the day and month names may be incorrect. */ - (format_string, _time)) + (format_string, time_)) { time_t value; size_t size; CHECK_STRING (format_string); - if (! lisp_to_time (_time, &value)) + if (! lisp_to_time (time_, &value)) error ("Invalid time specification"); /* This is probably enough. */ @@ -1115,13 +1114,13 @@ ZONE is an integer indicating the number of seconds east of Greenwich. error ("Invalid time specification"); decoded_time = localtime (&time_spec); - XSETINT (list_args[0], decoded_time->tm_sec); - XSETINT (list_args[1], decoded_time->tm_min); - XSETINT (list_args[2], decoded_time->tm_hour); - XSETINT (list_args[3], decoded_time->tm_mday); - XSETINT (list_args[4], decoded_time->tm_mon + 1); - XSETINT (list_args[5], decoded_time->tm_year + 1900); - XSETINT (list_args[6], decoded_time->tm_wday); + list_args[0] = make_int (decoded_time->tm_sec); + list_args[1] = make_int (decoded_time->tm_min); + list_args[2] = make_int (decoded_time->tm_hour); + list_args[3] = make_int (decoded_time->tm_mday); + list_args[4] = make_int (decoded_time->tm_mon + 1); + list_args[5] = make_int (decoded_time->tm_year + 1900); + list_args[6] = make_int (decoded_time->tm_wday); list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil; /* Make a copy, in case gmtime modifies the struct. */ @@ -1130,7 +1129,7 @@ ZONE is an integer indicating the number of seconds east of Greenwich. if (decoded_time == 0) list_args[8] = Qnil; else - XSETINT (list_args[8], difftm (&save_tm, decoded_time)); + list_args[8] = make_int (difftm (&save_tm, decoded_time)); return Flist (9, list_args); } @@ -1156,7 +1155,7 @@ If you want them to stand for years in this century, you must do that yourself. */ (int nargs, Lisp_Object *args)) { - time_t _time; + time_t the_time; struct tm tm; Lisp_Object zone = (nargs > 6) ? args[nargs - 1] : Qnil; @@ -1172,7 +1171,7 @@ If you want them to stand for years in this century, you must do that yourself. if (CONSP (zone)) zone = XCAR (zone); if (NILP (zone)) - _time = mktime (&tm); + the_time = mktime (&tm); else { char tzbuf[100]; @@ -1195,7 +1194,7 @@ If you want them to stand for years in this century, you must do that yourself. value doesn't suffice, since that would mishandle leap seconds. */ set_time_zone_rule (tzstring); - _time = mktime (&tm); + the_time = mktime (&tm); /* Restore TZ to previous value. */ newenv = environ; @@ -1206,10 +1205,10 @@ If you want them to stand for years in this century, you must do that yourself. #endif } - if (_time == (time_t) -1) + if (the_time == (time_t) -1) error ("Specified time is not representable"); - return wasteful_word_to_lisp (_time); + return wasteful_word_to_lisp (the_time); } DEFUN ("current-time-string", Fcurrent_time_string, 0, 1, 0, /* diff --git a/src/elhash.c b/src/elhash.c index 0d60ddf..e956a2f 100644 --- a/src/elhash.c +++ b/src/elhash.c @@ -1,4 +1,4 @@ -/* Lisp interface to hash tables. +/* Implementation of the hash table lisp object type. Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. Copyright (C) 1995, 1996 Ben Wing. Copyright (C) 1997 Free Software Foundation, Inc. @@ -11,7 +11,7 @@ Free Software Foundation; either version 2, or (at your option) any later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +ANY WARRANTY; without even the implied warranty of MERCNTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. @@ -24,122 +24,237 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" -#include "hash.h" -#include "elhash.h" #include "bytecode.h" +#include "elhash.h" -EXFUN (Fmake_weak_hashtable, 2); -EXFUN (Fmake_key_weak_hashtable, 2); -EXFUN (Fmake_value_weak_hashtable, 2); - -Lisp_Object Qhashtablep, Qhashtable; +Lisp_Object Qhash_tablep, Qhashtable, Qhash_table; Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak; +static Lisp_Object Vall_weak_hash_tables; +static Lisp_Object Qrehash_size, Qrehash_threshold; +static Lisp_Object Q_size, Q_test, Q_type, Q_rehash_size, Q_rehash_threshold; -#define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */ +typedef struct hentry +{ + Lisp_Object key; + Lisp_Object value; +} hentry; -struct hashtable +struct Lisp_Hash_Table { struct lcrecord_header header; - unsigned int fullness; - unsigned long (*hash_function) (CONST void *); - int (*test_function) (CONST void *, CONST void *); - Lisp_Object zero_entry; - Lisp_Object harray; - enum hashtable_type type; /* whether and how this hashtable is weak */ - Lisp_Object next_weak; /* Used to chain together all of the weak - hashtables. Don't mark through this. */ + size_t size; + size_t count; + size_t rehash_count; + double rehash_size; + double rehash_threshold; + size_t golden; + hash_table_hash_function_t hash_function; + hash_table_test_function_t test_function; + hentry *hentries; + enum hash_table_type type; /* whether and how this hash table is weak */ + Lisp_Object next_weak; /* Used to chain together all of the weak + hash tables. Don't mark through this. */ }; +typedef struct Lisp_Hash_Table Lisp_Hash_Table; + +#define HENTRY_CLEAR_P(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) == 0) +#define CLEAR_HENTRY(hentry) ((*(EMACS_UINT*)(&((hentry)->key))) = 0) + +#define HASH_TABLE_DEFAULT_SIZE 16 +#define HASH_TABLE_DEFAULT_REHASH_SIZE 1.3 +#define HASH_TABLE_MIN_SIZE 10 + +#define HASH_CODE(key, ht) \ + (((((ht)->hash_function ? (ht)->hash_function (key) : LISP_HASH (key)) \ + * (ht)->golden) \ + % (ht)->size)) + +#define KEYS_EQUAL_P(key1, key2, testfun) \ + (EQ ((key1), (key2)) || ((testfun) && (testfun) ((key1), (key2)))) + +#define LINEAR_PROBING_LOOP(probe, entries, size) \ + for (; \ + !HENTRY_CLEAR_P (probe) || \ + (probe == entries + size ? \ + (probe = entries, !HENTRY_CLEAR_P (probe)) : 0); \ + probe++) + +#ifndef ERROR_CHECK_HASH_TABLE +# ifdef ERROR_CHECK_TYPECHECK +# define ERROR_CHECK_HASH_TABLE 1 +# else +# define ERROR_CHECK_HASH_TABLE 0 +# endif +#endif -static Lisp_Object Vall_weak_hashtables; - -static Lisp_Object -mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object)) +#if ERROR_CHECK_HASH_TABLE +static void +check_hash_table_invariants (Lisp_Hash_Table *ht) { - struct hashtable *table = XHASHTABLE (obj); + assert (ht->count < ht->size); + assert (ht->count <= ht->rehash_count); + assert (ht->rehash_count < ht->size); + assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count); + assert (HENTRY_CLEAR_P (ht->hentries + ht->size)); +} +#else +#define check_hash_table_invariants(ht) +#endif + +/* We use linear probing instead of double hashing, despite its lack + of blessing by Knuth and company, because, as a result of the + increasing discrepancy between CPU speeds and memory speeds, cache + behavior is becoming increasingly important, e.g: + + For a trivial loop, the penalty for non-sequential access of an array is: + - a factor of 3-4 on Pentium Pro 200 Mhz + - a factor of 10 on Ultrasparc 300 Mhz */ - if (table->type != HASHTABLE_NONWEAK) +/* Return a suitable size for a hash table, with at least SIZE slots. */ +static size_t +hash_table_size (size_t requested_size) +{ + /* Return some prime near, but greater than or equal to, SIZE. + Decades from the time of writing, someone will have a system large + enough that the list below will be too short... */ + static CONST size_t primes [] = + { + 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031, + 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783, + 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941, + 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519, + 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301, + 10445899, 13579681, 17653589, 22949669, 29834603, 38784989, + 50420551, 65546729, 85210757, 110774011, 144006217, 187208107, + 243370577, 316381771, 411296309, 534685237, 695090819, 903618083, + 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL + }; + /* We've heard of binary search. */ + int low, high; + for (low = 0, high = countof (primes) - 1; high - low > 1;) { - /* If the table is weak, we don't want to mark the keys and values - (we scan over them after everything else has been marked, - and mark or remove them as necessary). Note that we will mark - the table->harray itself at the same time; it's hard to mark - that here without also marking its contents. */ - return Qnil; + /* Loop Invariant: size < primes [high] */ + int mid = (low + high) / 2; + if (primes [mid] < requested_size) + low = mid; + else + high = mid; } - ((markobj) (table->zero_entry)); - return table->harray; + return primes [high]; } + -/* Equality of hashtables. Two hashtables are equal when they are of - the same type and test function, they have the same number of - elements, and for each key in hashtable, the values are `equal'. +#if 0 /* I don't think these are needed any more. + If using the general lisp_object_equal_*() functions + causes efficiency problems, these can be resurrected. --ben */ +/* equality and hash functions for Lisp strings */ +int +lisp_string_equal (Lisp_Object str1, Lisp_Object str2) +{ + /* This is wrong anyway. You can't use strcmp() on Lisp strings, + because they can contain zero characters. */ + return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2)); +} - This is similar to Common Lisp `equalp' of hashtables, with the - difference that CL requires the keys to be compared with the test - function, which we don't do. Doing that would require consing, and - consing is bad idea in `equal'. Anyway, our method should provide - the same result -- if the keys are not equal according to test - function, then Fgethash() in hashtable_equal_mapper() will fail. */ -struct hashtable_equal_closure +static hashcode_t +lisp_string_hash (Lisp_Object obj) { - int depth; - int equal; - Lisp_Object other_table; -}; + return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str)); +} + +#endif /* 0 */ + +static int +lisp_object_eql_equal (Lisp_Object obj1, Lisp_Object obj2) +{ + return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0)); +} + +static hashcode_t +lisp_object_eql_hash (Lisp_Object obj) +{ + return FLOATP (obj) ? internal_hash (obj, 0) : LISP_HASH (obj); +} static int -hashtable_equal_mapper (CONST void *key, void *contents, void *arg) +lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) { - struct hashtable_equal_closure *closure = - (struct hashtable_equal_closure *)arg; - Lisp_Object keytem, valuetem; - Lisp_Object value_in_other; - - CVOID_TO_LISP (keytem, key); - CVOID_TO_LISP (valuetem, contents); - /* Look up the key in the other hashtable, and compare the values. */ - value_in_other = Fgethash (keytem, closure->other_table, Qunbound); - if (UNBOUNDP (value_in_other) - || !internal_equal (valuetem, value_in_other, closure->depth)) + return internal_equal (obj1, obj2, 0); +} + +static hashcode_t +lisp_object_equal_hash (Lisp_Object obj) +{ + return internal_hash (obj, 0); +} + + +static Lisp_Object +mark_hash_table (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + Lisp_Hash_Table *ht = XHASH_TABLE (obj); + + /* If the hash table is weak, we don't want to mark the keys and + values (we scan over them after everything else has been marked, + and mark or remove them as necessary). */ + if (ht->type == HASH_TABLE_NON_WEAK) { - /* Give up. */ - closure->equal = 0; - return 1; + hentry *e, *sentinel; + + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + markobj (e->key); + markobj (e->value); + } } - return 0; + return Qnil; } + +/* Equality of hash tables. Two hash tables are equal when they are of + the same type and test function, they have the same number of + elements, and for each key in the hash table, the values are `equal'. + This is similar to Common Lisp `equalp' of hash tables, with the + difference that CL requires the keys to be compared with the test + function, which we don't do. Doing that would require consing, and + consing is a bad idea in `equal'. Anyway, our method should provide + the same result -- if the keys are not equal according to the test + function, then Fgethash() in hash_table_equal_mapper() will fail. */ static int -hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth) +hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth) { - struct hashtable_equal_closure closure; - struct hashtable *table1 = XHASHTABLE (t1); - struct hashtable *table2 = XHASHTABLE (t2); - - /* The objects are `equal' if they are of the same type, so return 0 - if types or test functions are not the same. Obviously, the - number of elements must be equal, too. #### table->fullness is - broken, so we cannot use it. */ - if ((table1->test_function != table2->test_function) - || (table1->type != table2->type) - /*|| (table1->fullness != table2->fullness))*/ - ) + Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); + Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); + hentry *e, *sentinel; + + if ((ht1->test_function != ht2->test_function) || + (ht1->type != ht2->type) || + (ht1->count != ht2->count)) return 0; - closure.depth = depth + 1; - closure.equal = 1; - closure.other_table = t2; - elisp_maphash (hashtable_equal_mapper, t1, &closure); - return closure.equal; + depth++; + + for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + /* Look up the key in the other hash table, and compare the values. */ + { + Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound); + if (UNBOUNDP (value_in_other) || + !internal_equal (e->value, value_in_other, depth)) + return 0; /* Give up */ + } + + return 1; } -/* Printing hashtables. +/* Printing hash tables. This is non-trivial, because we use a readable structure-style - syntax for hashtables. This means that a typical hashtable will be + syntax for hash tables. This means that a typical hash table will be readably printed in the form of: - #s(hashtable size 2 data (key1 value1 key2 value2)) + #s(hash-table size 2 data (key1 value1 key2 value2)) The supported keywords are `type' (non-weak (or nil), weak, key-weak and value-weak), `test' (eql (or nil), eq or equal), @@ -148,210 +263,399 @@ hashtable_equal (Lisp_Object t1, Lisp_Object t2, int depth) If `print-readably' is non-nil, then a simpler syntax is used; for instance: - # + # The data is truncated to four pairs, and the rest is shown with `...'. This printer does not cons. */ -struct print_hashtable_data_closure -{ - EMACS_INT count; /* Used to implement truncation for - non-readable printing, as well as - to avoid the unnecessary space at - the beginning. */ - Lisp_Object printcharfun; -}; - -static int -print_hashtable_data_mapper (CONST void *key, void *contents, void *arg) -{ - Lisp_Object keytem, valuetem; - struct print_hashtable_data_closure *closure = - (struct print_hashtable_data_closure *)arg; - if (closure->count < 4 || print_readably) - { - CVOID_TO_LISP (keytem, key); - CVOID_TO_LISP (valuetem, contents); - - if (closure->count) - write_c_string (" ", closure->printcharfun); - - print_internal (keytem, closure->printcharfun, 1); - write_c_string (" ", closure->printcharfun); - print_internal (valuetem, closure->printcharfun, 1); - } - ++closure->count; - return 0; -} - -/* Print the data of the hashtable. This maps through a Lisp - hashtable and prints key/value pairs using PRINTCHARFUN. */ +/* Print the data of the hash table. This maps through a Lisp + hash table and prints key/value pairs using PRINTCHARFUN. */ static void -print_hashtable_data (Lisp_Object hashtable, Lisp_Object printcharfun) +print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun) { - struct print_hashtable_data_closure closure; - closure.count = 0; - closure.printcharfun = printcharfun; + int count = 0; + hentry *e, *sentinel; write_c_string (" data (", printcharfun); - elisp_maphash (print_hashtable_data_mapper, hashtable, &closure); - write_c_string ((!print_readably && closure.count > 4) ? " ...)" : ")", - printcharfun); -} -/* Needed for tests. */ -static int lisp_object_eql_equal (CONST void *x1, CONST void *x2); -static int lisp_object_equal_equal (CONST void *x1, CONST void *x2); + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + if (count > 0) + write_c_string (" ", printcharfun); + if (!print_readably && count > 3) + { + write_c_string ("...", printcharfun); + break; + } + print_internal (e->key, printcharfun, 1); + write_c_string (" ", printcharfun); + print_internal (e->value, printcharfun, 1); + count++; + } + + write_c_string (")", printcharfun); +} static void -print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) +print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - struct hashtable *table = XHASHTABLE (obj); + Lisp_Hash_Table *ht = XHASH_TABLE (obj); char buf[128]; - write_c_string (print_readably ? "#s(hashtable" : "#type != HASHTABLE_NONWEAK) + + if (ht->type != HASH_TABLE_NON_WEAK) { sprintf (buf, " type %s", - (table->type == HASHTABLE_WEAK ? "weak" : - table->type == HASHTABLE_KEY_WEAK ? "key-weak" : - table->type == HASHTABLE_VALUE_WEAK ? "value-weak" : + (ht->type == HASH_TABLE_WEAK ? "weak" : + ht->type == HASH_TABLE_KEY_WEAK ? "key-weak" : + ht->type == HASH_TABLE_VALUE_WEAK ? "value-weak" : "you-d-better-not-see-this")); write_c_string (buf, printcharfun); } - /* These checks have a kludgy look to them, but they are safe. Due - to nature of hashing, you cannot use arbitrary test functions - anyway. */ - if (!table->test_function) + + /* These checks have a kludgy look to them, but they are safe. + Due to nature of hashing, you cannot use arbitrary + test functions anyway. */ + if (!ht->test_function) write_c_string (" test eq", printcharfun); - else if (table->test_function == lisp_object_equal_equal) + else if (ht->test_function == lisp_object_equal_equal) write_c_string (" test equal", printcharfun); - else if (table->test_function == lisp_object_eql_equal) + else if (ht->test_function == lisp_object_eql_equal) DO_NOTHING; else abort (); - if (table->fullness || !print_readably) + + if (ht->count || !print_readably) { if (print_readably) - sprintf (buf, " size %u", table->fullness); + sprintf (buf, " size %lu", (unsigned long) ht->count); else - sprintf (buf, " size %u/%ld", table->fullness, - XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY); + sprintf (buf, " size %lu/%lu", + (unsigned long) ht->count, + (unsigned long) ht->size); write_c_string (buf, printcharfun); } - if (table->fullness) - print_hashtable_data (obj, printcharfun); + + if (ht->count) + print_hash_table_data (ht, printcharfun); + if (print_readably) write_c_string (")", printcharfun); else { - sprintf (buf, " 0x%x>", table->header.uid); + sprintf (buf, " 0x%x>", ht->header.uid); write_c_string (buf, printcharfun); } } -DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable, - mark_hashtable, print_hashtable, 0, - /* #### Implement hashtable_hash()! */ - hashtable_equal, 0, - struct hashtable); +static void +finalize_hash_table (void *header, int for_disksave) +{ + if (!for_disksave) + { + Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header; + + xfree (ht->hentries); + ht->hentries = 0; + } +} + +DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, + mark_hash_table, print_hash_table, + finalize_hash_table, + /* #### Implement hash_table_hash()! */ + hash_table_equal, 0, + Lisp_Hash_Table); + +static Lisp_Hash_Table * +xhash_table (Lisp_Object hash_table) +{ + if (!gc_in_progress) + CHECK_HASH_TABLE (hash_table); + check_hash_table_invariants (XHASH_TABLE (hash_table)); + return XHASH_TABLE (hash_table); +} + -/* Pretty reading of hashtables. +/************************************************************************/ +/* Creation of Hash Tables */ +/************************************************************************/ + +/* Creation of hash tables, without error-checking. */ +static double +hash_table_rehash_threshold (Lisp_Hash_Table *ht) +{ + return + ht->rehash_threshold > 0.0 ? ht->rehash_threshold : + ht->size > 4096 && !ht->test_function ? 0.7 : 0.6; +} + +static void +compute_hash_table_derived_values (Lisp_Hash_Table *ht) +{ + ht->rehash_count = (size_t) + ((double) ht->size * hash_table_rehash_threshold (ht)); + ht->golden = (size_t) + ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object))); +} + +Lisp_Object +make_general_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test, + double rehash_size, + double rehash_threshold) +{ + Lisp_Object hash_table; + Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, lrecord_hash_table); + + ht->type = type; + ht->rehash_size = rehash_size; + ht->rehash_threshold = rehash_threshold; + + switch (test) + { + case HASH_TABLE_EQ: + ht->test_function = 0; + ht->hash_function = 0; + break; + + case HASH_TABLE_EQL: + ht->test_function = lisp_object_eql_equal; + ht->hash_function = lisp_object_eql_hash; + break; + + case HASH_TABLE_EQUAL: + ht->test_function = lisp_object_equal_equal; + ht->hash_function = lisp_object_equal_hash; + break; + + default: + abort (); + } + + if (ht->rehash_size <= 0.0) + ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE; + if (size < HASH_TABLE_MIN_SIZE) + size = HASH_TABLE_MIN_SIZE; + if (rehash_threshold < 0.0) + rehash_threshold = 0.75; + ht->size = + hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1); + ht->count = 0; + compute_hash_table_derived_values (ht); + + /* We leave room for one never-occupied sentinel hentry at the end. */ + ht->hentries = xnew_array (hentry, ht->size + 1); + + { + hentry *e, *sentinel; + for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++) + CLEAR_HENTRY (e); + } + + XSETHASH_TABLE (hash_table, ht); + + if (type == HASH_TABLE_NON_WEAK) + ht->next_weak = Qunbound; + else + ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table; + + return hash_table; +} + +Lisp_Object +make_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test) +{ + return make_general_lisp_hash_table (size, type, test, + HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0); +} + +/* Pretty reading of hash tables. Here we use the existing structures mechanism (which is, unfortunately, pretty cumbersome) for validating and instantiating - the hashtables. The idea is that the side-effect of reading a - #s(hashtable PLIST) object is creation of a hashtable with desired - properties, and that the hashtable is returned. */ + the hash tables. The idea is that the side-effect of reading a + #s(hash-table PLIST) object is creation of a hash table with desired + properties, and that the hash table is returned. */ /* Validation functions: each keyword provides its own validation function. The errors should maybe be continuable, but it is unclear how this would cope with ERRB. */ static int -hashtable_type_validate (Lisp_Object keyword, Lisp_Object value, +hash_table_size_validate (Lisp_Object keyword, Lisp_Object value, Error_behavior errb) { - if (!(NILP (value) - || EQ (value, Qnon_weak) - || EQ (value, Qweak) - || EQ (value, Qkey_weak) - || EQ (value, Qvalue_weak))) - { - maybe_signal_simple_error ("Invalid hashtable type", value, - Qhashtable, errb); - return 0; - } - return 1; + if (NATNUMP (value)) + return 1; + + maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value), + Qhash_table, errb); + return 0; +} + +static size_t +decode_hash_table_size (Lisp_Object obj) +{ + return NILP (obj) ? HASH_TABLE_DEFAULT_SIZE : XINT (obj); } static int -hashtable_test_validate (Lisp_Object keyword, Lisp_Object value, +hash_table_type_validate (Lisp_Object keyword, Lisp_Object value, Error_behavior errb) { - if (!(NILP (value) - || EQ (value, Qeq) - || EQ (value, Qeql) - || EQ (value, Qequal))) + if (EQ (value, Qnil)) return 1; + if (EQ (value, Qnon_weak)) return 1; + if (EQ (value, Qweak)) return 1; + if (EQ (value, Qkey_weak)) return 1; + if (EQ (value, Qvalue_weak)) return 1; + + maybe_signal_simple_error ("Invalid hash table type", + value, Qhash_table, errb); + return 0; +} + +static enum hash_table_type +decode_hash_table_type (Lisp_Object obj) +{ + if (EQ (obj, Qnil)) return HASH_TABLE_NON_WEAK; + if (EQ (obj, Qnon_weak)) return HASH_TABLE_NON_WEAK; + if (EQ (obj, Qweak)) return HASH_TABLE_WEAK; + if (EQ (obj, Qkey_weak)) return HASH_TABLE_KEY_WEAK; + if (EQ (obj, Qvalue_weak)) return HASH_TABLE_VALUE_WEAK; + + signal_simple_error ("Invalid hash table type", obj); + return HASH_TABLE_NON_WEAK; /* not reached */ +} + +static int +hash_table_test_validate (Lisp_Object keyword, Lisp_Object value, + Error_behavior errb) +{ + if (EQ (value, Qnil)) return 1; + if (EQ (value, Qeq)) return 1; + if (EQ (value, Qequal)) return 1; + if (EQ (value, Qeql)) return 1; + + maybe_signal_simple_error ("Invalid hash table test", + value, Qhash_table, errb); + return 0; +} + +static enum hash_table_test +decode_hash_table_test (Lisp_Object obj) +{ + if (EQ (obj, Qnil)) return HASH_TABLE_EQL; + if (EQ (obj, Qeq)) return HASH_TABLE_EQ; + if (EQ (obj, Qequal)) return HASH_TABLE_EQUAL; + if (EQ (obj, Qeql)) return HASH_TABLE_EQL; + + signal_simple_error ("Invalid hash table test", obj); + return HASH_TABLE_EQ; /* not reached */ +} + +static int +hash_table_rehash_size_validate (Lisp_Object keyword, Lisp_Object value, + Error_behavior errb) +{ + if (!FLOATP (value)) { - maybe_signal_simple_error ("Invalid hashtable test", value, - Qhashtable, errb); + maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value), + Qhash_table, errb); return 0; } + + { + double rehash_size = XFLOAT_DATA (value); + if (rehash_size <= 1.0) + { + maybe_signal_simple_error + ("Hash table rehash size must be greater than 1.0", + value, Qhash_table, errb); + return 0; + } + } + return 1; } +static double +decode_hash_table_rehash_size (Lisp_Object rehash_size) +{ + return NILP (rehash_size) ? -1.0 : XFLOAT_DATA (rehash_size); +} + static int -hashtable_size_validate (Lisp_Object keyword, Lisp_Object value, - Error_behavior errb) +hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value, + Error_behavior errb) { - if (!NATNUMP (value)) + if (!FLOATP (value)) { - maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value), - Qhashtable, errb); + maybe_signal_error (Qwrong_type_argument, list2 (Qfloatp, value), + Qhash_table, errb); return 0; } + + { + double rehash_threshold = XFLOAT_DATA (value); + if (rehash_threshold <= 0.0 || rehash_threshold >= 1.0) + { + maybe_signal_simple_error + ("Hash table rehash threshold must be between 0.0 and 1.0", + value, Qhash_table, errb); + return 0; + } + } + return 1; } +static double +decode_hash_table_rehash_threshold (Lisp_Object rehash_threshold) +{ + return NILP (rehash_threshold) ? -1.0 : XFLOAT_DATA (rehash_threshold); +} + static int -hashtable_data_validate (Lisp_Object keyword, Lisp_Object value, +hash_table_data_validate (Lisp_Object keyword, Lisp_Object value, Error_behavior errb) { - int num = 0; - Lisp_Object tail; + int len; - /* #### Doesn't respect ERRB! */ - EXTERNAL_LIST_LOOP (tail, value) - { - ++num; - QUIT; - } - if (num & 1) + GET_EXTERNAL_LIST_LENGTH (value, len); + + if (len & 1) { maybe_signal_simple_error - ("Hashtable data must have alternating keyword/value pairs", value, - Qhashtable, errb); + ("Hash table data must have alternating key/value pairs", + value, Qhash_table, errb); return 0; } return 1; } -/* The actual instantiation of hashtable. This does practically no +/* The actual instantiation of a hash table. This does practically no error checking, because it relies on the fact that the paranoid functions above have error-checked everything to the last details. If this assumption is wrong, we will get a crash immediately (with error-checking compiled in), and we'll know if there is a bug in the structure mechanism. So there. */ static Lisp_Object -hashtable_instantiate (Lisp_Object plist) +hash_table_instantiate (Lisp_Object plist) { - /* I'm not sure whether this can GC, but better safe than sorry. */ - Lisp_Object hashtab = Qnil; - Lisp_Object type = Qnil, test = Qnil, size = Qnil, data = Qnil; - struct gcpro gcpro1; - GCPRO1 (hashtab); + Lisp_Object hash_table; + Lisp_Object test = Qnil; + Lisp_Object type = Qnil; + Lisp_Object size = Qnil; + Lisp_Object data = Qnil; + Lisp_Object rehash_size = Qnil; + Lisp_Object rehash_threshold = Qnil; while (!NILP (plist)) { @@ -359,808 +663,596 @@ hashtable_instantiate (Lisp_Object plist) key = XCAR (plist); plist = XCDR (plist); value = XCAR (plist); plist = XCDR (plist); - if (EQ (key, Qtype)) type = value; - else if (EQ (key, Qtest)) test = value; - else if (EQ (key, Qsize)) size = value; - else if (EQ (key, Qdata)) data = value; + if (EQ (key, Qtest)) test = value; + else if (EQ (key, Qtype)) type = value; + else if (EQ (key, Qsize)) size = value; + else if (EQ (key, Qdata)) data = value; + else if (EQ (key, Qrehash_size)) rehash_size = value; + else if (EQ (key, Qrehash_threshold)) rehash_threshold = value; else abort (); } - if (NILP (type)) - type = Qnon_weak; - - if (NILP (size)) - /* Divide by two, because data is a plist. */ - size = make_int (XINT (Flength (data)) / 2); - - /* Create the hashtable. */ - if (EQ (type, Qnon_weak)) - hashtab = Fmake_hashtable (size, test); - else if (EQ (type, Qweak)) - hashtab = Fmake_weak_hashtable (size, test); - else if (EQ (type, Qkey_weak)) - hashtab = Fmake_key_weak_hashtable (size, test); - else if (EQ (type, Qvalue_weak)) - hashtab = Fmake_value_weak_hashtable (size, test); - else - abort (); + /* Create the hash table. */ + hash_table = make_general_lisp_hash_table + (decode_hash_table_size (size), + decode_hash_table_type (type), + decode_hash_table_test (test), + decode_hash_table_rehash_size (rehash_size), + decode_hash_table_rehash_threshold (rehash_threshold)); - /* And fill it with data. */ - while (!NILP (data)) - { - Lisp_Object key, value; - key = XCAR (data); data = XCDR (data); - value = XCAR (data); data = XCDR (data); - Fputhash (key, value, hashtab); - } - - UNGCPRO; - return hashtab; -} + /* I'm not sure whether this can GC, but better safe than sorry. */ + { + struct gcpro gcpro1; + GCPRO1 (hash_table); -/* Initialize the hashtable as a structure type. This is called from - emacs.c. */ -void -structure_type_create_hashtable (void) -{ - struct structure_type *st; + /* And fill it with data. */ + while (!NILP (data)) + { + Lisp_Object key, value; + key = XCAR (data); data = XCDR (data); + value = XCAR (data); data = XCDR (data); + Fputhash (key, value, hash_table); + } + UNGCPRO; + } - st = define_structure_type (Qhashtable, 0, hashtable_instantiate); - define_structure_type_keyword (st, Qtype, hashtable_type_validate); - define_structure_type_keyword (st, Qtest, hashtable_test_validate); - define_structure_type_keyword (st, Qsize, hashtable_size_validate); - define_structure_type_keyword (st, Qdata, hashtable_data_validate); + return hash_table; } - -/* Basic conversion and allocation functions. */ -/* Create a C hashtable from the data in the Lisp hashtable. The - actual vector is not copied, nor are the keys or values copied. */ static void -ht_copy_to_c (struct hashtable *ht, c_hashtable c_table) +structure_type_create_hash_table_structure_name (Lisp_Object structure_name) { - int len = XVECTOR_LENGTH (ht->harray); + struct structure_type *st; - c_table->harray = (hentry *) XVECTOR_DATA (ht->harray); - c_table->zero_set = (!GC_UNBOUNDP (ht->zero_entry)); - c_table->zero_entry = LISP_TO_VOID (ht->zero_entry); -#ifndef LRECORD_VECTOR - if (len < 0) - { - /* #### if alloc.c mark_object() changes, this must change too. */ - /* barf gag retch. When a vector is marked, its len is - made less than 0. In the prune_weak_hashtables() stage, - we are called on vectors that are like this, and we must - be able to deal. */ - assert (gc_in_progress); - len = -1 - len; - } -#endif - c_table->size = len/LISP_OBJECTS_PER_HENTRY; - c_table->fullness = ht->fullness; - c_table->hash_function = ht->hash_function; - c_table->test_function = ht->test_function; - XSETHASHTABLE (c_table->elisp_table, ht); + st = define_structure_type (structure_name, 0, hash_table_instantiate); + define_structure_type_keyword (st, Qsize, hash_table_size_validate); + define_structure_type_keyword (st, Qtest, hash_table_test_validate); + define_structure_type_keyword (st, Qtype, hash_table_type_validate); + define_structure_type_keyword (st, Qdata, hash_table_data_validate); + define_structure_type_keyword (st, Qrehash_size, hash_table_rehash_size_validate); + define_structure_type_keyword (st, Qrehash_threshold, hash_table_rehash_threshold_validate); } -static void -ht_copy_from_c (c_hashtable c_table, struct hashtable *ht) +/* Create a built-in Lisp structure type named `hash-table'. + We make #s(hashtable ...) equivalent to #s(hash-table ...), + for backward comptabibility. + This is called from emacs.c. */ +void +structure_type_create_hash_table (void) { - struct Lisp_Vector dummy; - /* C is truly hateful */ - void *vec_addr - = ((char *) c_table->harray - - ((char *) &(dummy.contents[0]) - (char *) &dummy)); - - XSETVECTOR (ht->harray, vec_addr); - if (c_table->zero_set) - VOID_TO_LISP (ht->zero_entry, c_table->zero_entry); - else - ht->zero_entry = Qunbound; - ht->fullness = c_table->fullness; + structure_type_create_hash_table_structure_name (Qhash_table); + structure_type_create_hash_table_structure_name (Qhashtable); /* compat */ } + +/************************************************************************/ +/* Definition of Lisp-visible methods */ +/************************************************************************/ -static struct hashtable * -allocate_hashtable (void) +DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /* +Return t if OBJECT is a hash table, else nil. +*/ + (object)) { - struct hashtable *table = - alloc_lcrecord_type (struct hashtable, lrecord_hashtable); - table->harray = Qnil; - table->zero_entry = Qunbound; - table->fullness = 0; - table->hash_function = 0; - table->test_function = 0; - return table; + return HASH_TABLEP (object) ? Qt : Qnil; } -void * -elisp_hvector_malloc (unsigned int bytes, Lisp_Object table) -{ - Lisp_Object new_vector; - struct hashtable *ht = XHASHTABLE (table); +DEFUN ("make-hash-table", Fmake_hash_table, 0, MANY, 0, /* +Return a new empty hash table object. +Use Common Lisp style keywords to specify hash table properties. + (make-hash-table &key :size :test :type :rehash-size :rehash-threshold) - assert (bytes > XVECTOR_LENGTH (ht->harray) * sizeof (Lisp_Object)); - new_vector = make_vector ((bytes / sizeof (Lisp_Object)), Qnull_pointer); - return (void *) XVECTOR_DATA (new_vector); -} +Keyword :size specifies the number of keys likely to be inserted. +This number of entries can be inserted without enlarging the hash table. -void -elisp_hvector_free (void *ptr, Lisp_Object table) -{ - struct hashtable *ht = XHASHTABLE (table); -#if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS) - Lisp_Object current_vector = ht->harray; -#endif +Keyword :test can be `eq', `eql' (default) or `equal'. +Comparison between keys is done using this function. +If speed is important, consider using `eq'. +When storing strings in the hash table, you will likely need to use `equal'. - assert (((void *) XVECTOR_DATA (current_vector)) == ptr); - ht->harray = Qnil; /* Let GC do its job */ -} +Keyword :type can be `non-weak' (default), `weak', `key-weak' or `value-weak'. + +A weak hash table is one whose pointers do not count as GC referents: +for any key-value pair in the hash table, if the only remaining pointer +to either the key or the value is in a weak hash table, then the pair +will be removed from the hash table, and the key and value collected. +A non-weak hash table (or any other pointer) would prevent the object +from being collected. +A key-weak hash table is similar to a fully-weak hash table except that +a key-value pair will be removed only if the key remains unmarked +outside of weak hash tables. The pair will remain in the hash table if +the key is pointed to by something other than a weak hash table, even +if the value is not. -DEFUN ("hashtablep", Fhashtablep, 1, 1, 0, /* -Return t if OBJ is a hashtable, else nil. -*/ - (obj)) -{ - return HASHTABLEP (obj) ? Qt : Qnil; -} +A value-weak hash table is similar to a fully-weak hash table except +that a key-value pair will be removed only if the value remains +unmarked outside of weak hash tables. The pair will remain in the +hash table if the value is pointed to by something other than a weak +hash table, even if the key is not. +Keyword :rehash-size must be a float greater than 1.0, and specifies +the factor by which to increase the size of the hash table when enlarging. - +Keyword :rehash-threshold must be a float between 0.0 and 1.0, +and specifies the load factor of the hash table which triggers enlarging. -#if 0 /* I don't think these are needed any more. - If using the general lisp_object_equal_*() functions - causes efficiency problems, these can be resurrected. --ben */ -/* equality and hash functions for Lisp strings */ -int -lisp_string_equal (CONST void *x1, CONST void *x2) +*/ + (int nargs, Lisp_Object *args)) { - /* This is wrong anyway. You can't use strcmp() on Lisp strings, - because they can contain zero characters. */ - Lisp_Object str1, str2; - CVOID_TO_LISP (str1, x1); - CVOID_TO_LISP (str2, x2); - return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2)); + int j = 0; + Lisp_Object size = Qnil; + Lisp_Object type = Qnil; + Lisp_Object test = Qnil; + Lisp_Object rehash_size = Qnil; + Lisp_Object rehash_threshold = Qnil; + + while (j < nargs) + { + Lisp_Object keyword, value; + + keyword = args[j++]; + if (!KEYWORDP (keyword)) + signal_simple_error ("Invalid hash table property keyword", keyword); + if (j == nargs) + signal_simple_error ("Hash table property requires a value", keyword); + + value = args[j++]; + + if (EQ (keyword, Q_size)) size = value; + else if (EQ (keyword, Q_type)) type = value; + else if (EQ (keyword, Q_test)) test = value; + else if (EQ (keyword, Q_rehash_size)) rehash_size = value; + else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value; + else signal_simple_error ("Invalid hash table property keyword", keyword); + } + +#define VALIDATE_VAR(var) \ +if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME); + + VALIDATE_VAR (size); + VALIDATE_VAR (type); + VALIDATE_VAR (test); + VALIDATE_VAR (rehash_size); + VALIDATE_VAR (rehash_threshold); + + return make_general_lisp_hash_table + (decode_hash_table_size (size), + decode_hash_table_type (type), + decode_hash_table_test (test), + decode_hash_table_rehash_size (rehash_size), + decode_hash_table_rehash_threshold (rehash_threshold)); } -unsigned long -lisp_string_hash (CONST void *x) +DEFUN ("copy-hash-table", Fcopy_hash_table, 1, 1, 0, /* +Return a new hash table containing the same keys and values as HASH-TABLE. +The keys and values will not themselves be copied. +*/ + (hash_table)) { - Lisp_Object str; - CVOID_TO_LISP (str, x); - return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str)); -} + CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table); + Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, lrecord_hash_table); -#endif /* 0 */ + copy_lcrecord (ht, ht_old); -static int -lisp_object_eql_equal (CONST void *x1, CONST void *x2) -{ - Lisp_Object obj1, obj2; - CVOID_TO_LISP (obj1, x1); - CVOID_TO_LISP (obj2, x2); - return FLOATP (obj1) ? internal_equal (obj1, obj2, 0) : EQ (obj1, obj2); -} + ht->hentries = xnew_array (hentry, ht_old->size + 1); + memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry)); -static unsigned long -lisp_object_eql_hash (CONST void *x) -{ - Lisp_Object obj; - CVOID_TO_LISP (obj, x); - if (FLOATP (obj)) - return internal_hash (obj, 0); - else - return LISP_HASH (obj); -} + XSETHASH_TABLE (hash_table, ht); -static int -lisp_object_equal_equal (CONST void *x1, CONST void *x2) -{ - Lisp_Object obj1, obj2; - CVOID_TO_LISP (obj1, x1); - CVOID_TO_LISP (obj2, x2); - return internal_equal (obj1, obj2, 0); -} + if (! EQ (ht->next_weak, Qunbound)) + { + ht->next_weak = Vall_weak_hash_tables; + Vall_weak_hash_tables = hash_table; + } -static unsigned long -lisp_object_equal_hash (CONST void *x) -{ - Lisp_Object obj; - CVOID_TO_LISP (obj, x); - return internal_hash (obj, 0); + return hash_table; } -Lisp_Object -make_lisp_hashtable (int size, - enum hashtable_type type, - enum hashtable_test_fun test) +static void +enlarge_hash_table (Lisp_Hash_Table *ht) { - Lisp_Object result; - struct hashtable *table = allocate_hashtable (); + hentry *old_entries, *new_entries, *old_sentinel, *new_sentinel, *e; + size_t old_size, new_size; - table->harray = make_vector ((compute_harray_size (size) - * LISP_OBJECTS_PER_HENTRY), - Qnull_pointer); - switch (test) - { - case HASHTABLE_EQ: - table->test_function = NULL; - table->hash_function = NULL; - break; + old_size = ht->size; + new_size = ht->size = + hash_table_size ((size_t) ((double) old_size * ht->rehash_size)); - case HASHTABLE_EQL: - table->test_function = lisp_object_eql_equal; - table->hash_function = lisp_object_eql_hash; - break; + old_entries = ht->hentries; - case HASHTABLE_EQUAL: - table->test_function = lisp_object_equal_equal; - table->hash_function = lisp_object_equal_hash; - break; + ht->hentries = xnew_array (hentry, new_size + 1); + new_entries = ht->hentries; - default: - abort (); - } + old_sentinel = old_entries + old_size; + new_sentinel = new_entries + new_size; - table->type = type; - XSETHASHTABLE (result, table); + for (e = new_entries; e <= new_sentinel; e++) + CLEAR_HENTRY (e); - if (table->type != HASHTABLE_NONWEAK) - { - table->next_weak = Vall_weak_hashtables; - Vall_weak_hashtables = result; - } - else - table->next_weak = Qunbound; + compute_hash_table_derived_values (ht); + + for (e = old_entries; e < old_sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + hentry *probe = new_entries + HASH_CODE (e->key, ht); + LINEAR_PROBING_LOOP (probe, new_entries, new_size) + ; + *probe = *e; + } - return result; + xfree (old_entries); } -static enum hashtable_test_fun -decode_hashtable_test_fun (Lisp_Object sym) +static hentry * +find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht) { - if (NILP (sym)) return HASHTABLE_EQL; - if (EQ (sym, Qeq)) return HASHTABLE_EQ; - if (EQ (sym, Qequal)) return HASHTABLE_EQUAL; - if (EQ (sym, Qeql)) return HASHTABLE_EQL; + hash_table_test_function_t test_function = ht->test_function; + hentry *entries = ht->hentries; + hentry *probe = entries + HASH_CODE (key, ht); - signal_simple_error ("Invalid hashtable test function", sym); - return HASHTABLE_EQ; /* not reached */ -} + LINEAR_PROBING_LOOP (probe, entries, ht->size) + if (KEYS_EQUAL_P (probe->key, key, test_function)) + break; -DEFUN ("make-hashtable", Fmake_hashtable, 1, 2, 0, /* -Return a new hashtable object of initial size SIZE. -Comparison between keys is done with TEST-FUN, which must be one of -`eq', `eql', or `equal'. The default is `eql'; i.e. two keys must -be the same object (or have the same floating-point value, for floats) -to be considered equivalent. + return probe; +} -See also `make-weak-hashtable', `make-key-weak-hashtable', and -`make-value-weak-hashtable'. +DEFUN ("gethash", Fgethash, 2, 3, 0, /* +Find hash value for KEY in HASH-TABLE. +If there is no corresponding value, return DEFAULT (which defaults to nil). */ - (size, test_fun)) + (key, hash_table, default_)) { - CHECK_NATNUM (size); - return make_lisp_hashtable (XINT (size), HASHTABLE_NONWEAK, - decode_hashtable_test_fun (test_fun)); + CONST Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e = find_hentry (key, ht); + + return HENTRY_CLEAR_P (e) ? default_ : e->value; } -DEFUN ("copy-hashtable", Fcopy_hashtable, 1, 1, 0, /* -Return a new hashtable containing the same keys and values as HASHTABLE. -The keys and values will not themselves be copied. +DEFUN ("puthash", Fputhash, 3, 3, 0, /* +Hash KEY to VALUE in HASH-TABLE. */ - (hashtable)) + (key, value, hash_table)) { - struct _C_hashtable old_htbl; - struct _C_hashtable new_htbl; - struct hashtable *old_ht; - struct hashtable *new_ht; - Lisp_Object result; - - CHECK_HASHTABLE (hashtable); - old_ht = XHASHTABLE (hashtable); - ht_copy_to_c (old_ht, &old_htbl); - - /* we can't just call Fmake_hashtable() here because that will make a - table that is slightly larger than the one we're trying to copy, - which will make copy_hash() blow up. */ - new_ht = allocate_hashtable (); - new_ht->fullness = 0; - new_ht->zero_entry = Qunbound; - new_ht->hash_function = old_ht->hash_function; - new_ht->test_function = old_ht->test_function; - new_ht->harray = Fmake_vector (Flength (old_ht->harray), Qnull_pointer); - ht_copy_to_c (new_ht, &new_htbl); - copy_hash (&new_htbl, &old_htbl); - ht_copy_from_c (&new_htbl, new_ht); - new_ht->type = old_ht->type; - XSETHASHTABLE (result, new_ht); - - if (UNBOUNDP (old_ht->next_weak)) - new_ht->next_weak = Qunbound; - else - { - new_ht->next_weak = Vall_weak_hashtables; - Vall_weak_hashtables = result; - } + Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e = find_hentry (key, ht); - return result; -} + if (!HENTRY_CLEAR_P (e)) + return e->value = value; + e->key = key; + e->value = value; -DEFUN ("gethash", Fgethash, 2, 3, 0, /* -Find hash value for KEY in HASHTABLE. -If there is no corresponding value, return DEFAULT (defaults to nil). -*/ - (key, hashtable, default_)) + if (++ht->count >= ht->rehash_count) + enlarge_hash_table (ht); + + return value; +} + +/* Remove hentry pointed at by PROBE. + Subsequent entries are removed and reinserted. + We don't use tombstones - too wasteful. */ +static void +remhash_1 (Lisp_Hash_Table *ht, hentry *entries, hentry *probe) { - CONST void *vval; - struct _C_hashtable htbl; - if (!gc_in_progress) - CHECK_HASHTABLE (hashtable); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - if (gethash (LISP_TO_VOID (key), &htbl, &vval)) + size_t size = ht->size; + CLEAR_HENTRY (probe++); + ht->count--; + + LINEAR_PROBING_LOOP (probe, entries, size) { - Lisp_Object val; - CVOID_TO_LISP (val, vval); - return val; + Lisp_Object key = probe->key; + hentry *probe2 = entries + HASH_CODE (key, ht); + LINEAR_PROBING_LOOP (probe2, entries, size) + if (EQ (probe2->key, key)) + /* hentry at probe doesn't need to move. */ + goto continue_outer_loop; + /* Move hentry from probe to new home at probe2. */ + *probe2 = *probe; + CLEAR_HENTRY (probe); + continue_outer_loop: continue; } - else - return default_; } - DEFUN ("remhash", Fremhash, 2, 2, 0, /* -Remove hash value for KEY in HASHTABLE. +Remove the entry for KEY from HASH-TABLE. +Do nothing if there is no entry for KEY in HASH-TABLE. */ - (key, hashtable)) + (key, hash_table)) { - struct _C_hashtable htbl; - CHECK_HASHTABLE (hashtable); + Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e = find_hentry (key, ht); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - remhash (LISP_TO_VOID (key), &htbl); - ht_copy_from_c (&htbl, XHASHTABLE (hashtable)); - return Qnil; -} + if (HENTRY_CLEAR_P (e)) + return Qnil; + remhash_1 (ht, ht->hentries, e); + return Qt; +} -DEFUN ("puthash", Fputhash, 3, 3, 0, /* -Hash KEY to VAL in HASHTABLE. +DEFUN ("clrhash", Fclrhash, 1, 1, 0, /* +Remove all entries from HASH-TABLE, leaving it empty. */ - (key, val, hashtable)) + (hash_table)) { - struct hashtable *ht; - void *vkey = LISP_TO_VOID (key); + Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e, *sentinel; - CHECK_HASHTABLE (hashtable); - ht = XHASHTABLE (hashtable); - if (!vkey) - ht->zero_entry = val; - else - { - struct gcpro gcpro1, gcpro2, gcpro3; - struct _C_hashtable htbl; - - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - GCPRO3 (key, val, hashtable); - puthash (vkey, LISP_TO_VOID (val), &htbl); - ht_copy_from_c (&htbl, XHASHTABLE (hashtable)); - UNGCPRO; - } - return val; + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + CLEAR_HENTRY (e); + ht->count = 0; + + return hash_table; } -DEFUN ("clrhash", Fclrhash, 1, 1, 0, /* -Remove all entries from HASHTABLE. +/************************************************************************/ +/* Accessor Functions */ +/************************************************************************/ + +DEFUN ("hash-table-count", Fhash_table_count, 1, 1, 0, /* +Return the number of entries in HASH-TABLE. */ - (hashtable)) + (hash_table)) { - struct _C_hashtable htbl; - CHECK_HASHTABLE (hashtable); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - clrhash (&htbl); - ht_copy_from_c (&htbl, XHASHTABLE (hashtable)); - return Qnil; + return make_int (xhash_table (hash_table)->count); } -DEFUN ("hashtable-fullness", Fhashtable_fullness, 1, 1, 0, /* -Return number of entries in HASHTABLE. +DEFUN ("hash-table-size", Fhash_table_size, 1, 1, 0, /* +Return the size of HASH-TABLE. +This is the current number of slots in HASH-TABLE, whether occupied or not. */ - (hashtable)) + (hash_table)) { - struct _C_hashtable htbl; - CHECK_HASHTABLE (hashtable); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - return make_int (htbl.fullness); + return make_int (xhash_table (hash_table)->size); } -DEFUN ("hashtable-type", Fhashtable_type, 1, 1, 0, /* -Return type of HASHTABLE. -This can be one of `non-weak', `weak', `key-weak' and `value-weak'. +DEFUN ("hash-table-type", Fhash_table_type, 1, 1, 0, /* +Return the type of HASH-TABLE. +This can be one of `non-weak', `weak', `key-weak' or `value-weak'. */ - (hashtable)) + (hash_table)) { - CHECK_HASHTABLE (hashtable); - - switch (XHASHTABLE (hashtable)->type) + switch (xhash_table (hash_table)->type) { - case HASHTABLE_WEAK: return Qweak; - case HASHTABLE_KEY_WEAK: return Qkey_weak; - case HASHTABLE_VALUE_WEAK: return Qvalue_weak; + case HASH_TABLE_WEAK: return Qweak; + case HASH_TABLE_KEY_WEAK: return Qkey_weak; + case HASH_TABLE_VALUE_WEAK: return Qvalue_weak; default: return Qnon_weak; } } -DEFUN ("hashtable-test-function", Fhashtable_test_function, 1, 1, 0, /* -Return test function of HASHTABLE. +DEFUN ("hash-table-test", Fhash_table_test, 1, 1, 0, /* +Return the test function of HASH-TABLE. This can be one of `eq', `eql' or `equal'. */ - (hashtable)) + (hash_table)) { - int (*fun) (CONST void *, CONST void *); - - CHECK_HASHTABLE (hashtable); - - fun = XHASHTABLE (hashtable)->test_function; + hash_table_test_function_t fun = xhash_table (hash_table)->test_function; - if (fun == lisp_object_eql_equal) - return Qeql; - else if (fun == lisp_object_equal_equal) - return Qequal; - else - return Qeq; + return (fun == lisp_object_eql_equal ? Qeql : + fun == lisp_object_equal_equal ? Qequal : + Qeq); } -static void -verify_function (Lisp_Object function, CONST char *description) +DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size, 1, 1, 0, /* +Return the current rehash size of HASH-TABLE. +This is a float greater than 1.0; the factor by which HASH-TABLE +is enlarged when the rehash threshold is exceeded. +*/ + (hash_table)) { - /* #### Unused DESCRIPTION? */ - if (SYMBOLP (function)) - { - if (NILP (function)) - return; - else - function = indirect_function (function, 1); - } - if (SUBRP (function) || COMPILED_FUNCTIONP (function)) - return; - else if (CONSP (function)) - { - Lisp_Object funcar = XCAR (function); - if ((SYMBOLP (funcar)) && (EQ (funcar, Qlambda) || - EQ (funcar, Qautoload))) - return; - } - signal_error (Qinvalid_function, list1 (function)); + return make_float (xhash_table (hash_table)->rehash_size); } -static int -lisp_maphash_function (CONST void *void_key, - void *void_val, - void *void_fn) +DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold, 1, 1, 0, /* +Return the current rehash threshold of HASH-TABLE. +This is a float between 0.0 and 1.0; the maximum `load factor' of HASH-TABLE, +beyond which the HASH-TABLE is enlarged by rehashing. +*/ + (hash_table)) { - /* This function can GC */ - Lisp_Object key, val, fn; - CVOID_TO_LISP (key, void_key); - VOID_TO_LISP (val, void_val); - VOID_TO_LISP (fn, void_fn); - call2 (fn, key, val); - return 0; + return make_float (hash_table_rehash_threshold (xhash_table (hash_table))); } - +/************************************************************************/ +/* Mapping Functions */ +/************************************************************************/ DEFUN ("maphash", Fmaphash, 2, 2, 0, /* -Map FUNCTION over entries in HASHTABLE, calling it with two args, -each key and value in the table. +Map FUNCTION over entries in HASH-TABLE, calling it with two args, +each key and value in HASH-TABLE. + +FUNCTION may not modify HASH-TABLE, with the one exception that FUNCTION +may remhash or puthash the entry currently being processed by FUNCTION. */ - (function, hashtable)) + (function, hash_table)) { - struct _C_hashtable htbl; - struct gcpro gcpro1, gcpro2; - - verify_function (function, GETTEXT ("hashtable mapping function")); - CHECK_HASHTABLE (hashtable); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - GCPRO2 (hashtable, function); - maphash (lisp_maphash_function, &htbl, LISP_TO_VOID (function)); - UNGCPRO; - return Qnil; -} + CONST Lisp_Hash_Table *ht = xhash_table (hash_table); + CONST hentry *e, *sentinel; + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + Lisp_Object args[3], key; + again: + key = e->key; + args[0] = function; + args[1] = key; + args[2] = e->value; + Ffuncall (countof (args), args); + /* Has FUNCTION done a remhash? */ + if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e)) + goto again; + } -/* This function is for mapping a *C* function over the elements of a - lisp hashtable. - */ -void -elisp_maphash (int (*function) (CONST void *key, void *contents, - void *extra_arg), - Lisp_Object hashtable, void *closure) -{ - struct _C_hashtable htbl; - - if (!gc_in_progress) CHECK_HASHTABLE (hashtable); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - maphash (function, &htbl, closure); + return Qnil; } +/* Map *C* function FUNCTION over the elements of a lisp hash table. */ void -elisp_map_remhash (remhash_predicate function, Lisp_Object hashtable, - void *closure) +elisp_maphash (maphash_function_t function, + Lisp_Object hash_table, void *extra_arg) { - struct _C_hashtable htbl; + CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); + CONST hentry *e, *sentinel; - if (!gc_in_progress) CHECK_HASHTABLE (hashtable); - ht_copy_to_c (XHASHTABLE (hashtable), &htbl); - map_remhash (function, &htbl, closure); - ht_copy_from_c (&htbl, XHASHTABLE (hashtable)); + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + Lisp_Object key; + again: + key = e->key; + if (function (key, e->value, extra_arg)) + return; + /* Has FUNCTION done a remhash? */ + if (!EQ (key, e->key) && !HENTRY_CLEAR_P (e)) + goto again; + } } -#if 0 +/* Remove all elements of a lisp hash table satisfying *C* predicate PREDICATE. */ void -elisp_table_op (Lisp_Object table, generic_hashtable_op op, void *arg1, - void *arg2, void *arg3) +elisp_map_remhash (maphash_function_t predicate, + Lisp_Object hash_table, void *extra_arg) { - struct _C_hashtable htbl; - CHECK_HASHTABLE (table); - ht_copy_to_c (XHASHTABLE (table), &htbl); - (*op) (&htbl, arg1, arg2, arg3); - ht_copy_from_c (&htbl, XHASHTABLE (table)); -} -#endif /* 0 */ - - - -DEFUN ("make-weak-hashtable", Fmake_weak_hashtable, 1, 2, 0, /* -Return a new fully weak hashtable object of initial size SIZE. -A weak hashtable is one whose pointers do not count as GC referents: -for any key-value pair in the hashtable, if the only remaining pointer -to either the key or the value is in a weak hash table, then the pair -will be removed from the table, and the key and value collected. A -non-weak hash table (or any other pointer) would prevent the object -from being collected. + Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); + hentry *e, *entries, *sentinel; -You can also create semi-weak hashtables; see `make-key-weak-hashtable' -and `make-value-weak-hashtable'. -*/ - (size, test_fun)) -{ - CHECK_NATNUM (size); - return make_lisp_hashtable (XINT (size), HASHTABLE_WEAK, - decode_hashtable_test_fun (test_fun)); -} - -DEFUN ("make-key-weak-hashtable", Fmake_key_weak_hashtable, 1, 2, 0, /* -Return a new key-weak hashtable object of initial size SIZE. -A key-weak hashtable is similar to a fully-weak hashtable (see -`make-weak-hashtable') except that a key-value pair will be removed -only if the key remains unmarked outside of weak hashtables. The pair -will remain in the hashtable if the key is pointed to by something other -than a weak hashtable, even if the value is not. -*/ - (size, test_fun)) -{ - CHECK_NATNUM (size); - return make_lisp_hashtable (XINT (size), HASHTABLE_KEY_WEAK, - decode_hashtable_test_fun (test_fun)); -} - -DEFUN ("make-value-weak-hashtable", Fmake_value_weak_hashtable, 1, 2, 0, /* -Return a new value-weak hashtable object of initial size SIZE. -A value-weak hashtable is similar to a fully-weak hashtable (see -`make-weak-hashtable') except that a key-value pair will be removed only -if the value remains unmarked outside of weak hashtables. The pair will -remain in the hashtable if the value is pointed to by something other -than a weak hashtable, even if the key is not. -*/ - (size, test_fun)) -{ - CHECK_NATNUM (size); - return make_lisp_hashtable (XINT (size), HASHTABLE_VALUE_WEAK, - decode_hashtable_test_fun (test_fun)); + for (e = entries = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + again: + if (predicate (e->key, e->value, extra_arg)) + { + remhash_1 (ht, entries, e); + if (!HENTRY_CLEAR_P (e)) + goto again; + } + } } -struct marking_closure -{ - int (*obj_marked_p) (Lisp_Object); - void (*markobj) (Lisp_Object); - enum hashtable_type type; - int did_mark; -}; - -static int -marking_mapper (CONST void *key, void *contents, void *closure) -{ - Lisp_Object keytem, valuetem; - struct marking_closure *fmh = - (struct marking_closure *) closure; - - /* This function is called over each pair in the hashtable. - We complete the marking for semi-weak hashtables. */ - CVOID_TO_LISP (keytem, key); - CVOID_TO_LISP (valuetem, contents); - - switch (fmh->type) - { - case HASHTABLE_KEY_WEAK: - if ((fmh->obj_marked_p) (keytem) && - !(fmh->obj_marked_p) (valuetem)) - { - (fmh->markobj) (valuetem); - fmh->did_mark = 1; - } - break; - - case HASHTABLE_VALUE_WEAK: - if ((fmh->obj_marked_p) (valuetem) && - !(fmh->obj_marked_p) (keytem)) - { - (fmh->markobj) (keytem); - fmh->did_mark = 1; - } - break; - - case HASHTABLE_KEY_CAR_WEAK: - if (!CONSP (keytem) || (fmh->obj_marked_p) (XCAR (keytem))) - { - if (!(fmh->obj_marked_p) (keytem)) - { - (fmh->markobj) (keytem); - fmh->did_mark = 1; - } - if (!(fmh->obj_marked_p) (valuetem)) - { - (fmh->markobj) (valuetem); - fmh->did_mark = 1; - } - } - break; - - case HASHTABLE_VALUE_CAR_WEAK: - if (!CONSP (valuetem) || (fmh->obj_marked_p) (XCAR (valuetem))) - { - if (!(fmh->obj_marked_p) (keytem)) - { - (fmh->markobj) (keytem); - fmh->did_mark = 1; - } - if (!(fmh->obj_marked_p) (valuetem)) - { - (fmh->markobj) (valuetem); - fmh->did_mark = 1; - } - } - break; - - default: - abort (); /* Huh? */ - } - - return 0; -} + +/************************************************************************/ +/* garbage collecting weak hash tables */ +/************************************************************************/ +/* Complete the marking for semi-weak hash tables. */ int -finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object), +finish_marking_weak_hash_tables (int (*obj_marked_p) (Lisp_Object), void (*markobj) (Lisp_Object)) { - Lisp_Object rest; + Lisp_Object hash_table; int did_mark = 0; - for (rest = Vall_weak_hashtables; - !GC_NILP (rest); - rest = XHASHTABLE (rest)->next_weak) + for (hash_table = Vall_weak_hash_tables; + !GC_NILP (hash_table); + hash_table = XHASH_TABLE (hash_table)->next_weak) { - enum hashtable_type type; + CONST Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); + CONST hentry *e = ht->hentries; + CONST hentry *sentinel = e + ht->size; - if (! ((*obj_marked_p) (rest))) - /* The hashtable is probably garbage. Ignore it. */ + if (! obj_marked_p (hash_table)) + /* The hash table is probably garbage. Ignore it. */ continue; - type = XHASHTABLE (rest)->type; - if (type == HASHTABLE_KEY_WEAK || - type == HASHTABLE_VALUE_WEAK || - type == HASHTABLE_KEY_CAR_WEAK || - type == HASHTABLE_VALUE_CAR_WEAK) + + /* Now, scan over all the pairs. For all pairs that are + half-marked, we may need to mark the other half if we're + keeping this pair. */ +#define MARK_OBJ(obj) \ +do { if (!obj_marked_p (obj)) markobj (obj), did_mark = 1; } while (0) + + switch (ht->type) { - struct marking_closure fmh; - - fmh.obj_marked_p = obj_marked_p; - fmh.markobj = markobj; - fmh.type = type; - fmh.did_mark = 0; - /* Now, scan over all the pairs. For all pairs that are - half-marked, we may need to mark the other half if we're - keeping this pair. */ - elisp_maphash (marking_mapper, rest, &fmh); - if (fmh.did_mark) - did_mark = 1; + case HASH_TABLE_KEY_WEAK: + for (; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + if (obj_marked_p (e->key)) + MARK_OBJ (e->value); + break; + + case HASH_TABLE_VALUE_WEAK: + for (; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + if (obj_marked_p (e->value)) + MARK_OBJ (e->key); + break; + + case HASH_TABLE_KEY_CAR_WEAK: + for (; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + if (!CONSP (e->key) || obj_marked_p (XCAR (e->key))) + { + MARK_OBJ (e->key); + MARK_OBJ (e->value); + } + break; + + case HASH_TABLE_VALUE_CAR_WEAK: + for (; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + if (!CONSP (e->value) || obj_marked_p (XCAR (e->value))) + { + MARK_OBJ (e->key); + MARK_OBJ (e->value); + } + break; + + default: + break; } - - /* #### If alloc.c mark_object changes, this must change also... */ - { - /* Now mark the vector itself. (We don't need to call markobj - here because we know that everything *in* it is already marked, - we just need to prevent the vector itself from disappearing.) - (The remhash above has taken care of zero_entry.) - */ - struct Lisp_Vector *ptr = XVECTOR (XHASHTABLE (rest)->harray); -#ifdef LRECORD_VECTOR - if (! MARKED_RECORD_P(XHASHTABLE(rest)->harray)) - { - MARK_RECORD_HEADER(&(ptr->header.lheader)); - did_mark = 1; - } -#else - int len = vector_length (ptr); - if (len >= 0) - { - ptr->size = -1 - len; - did_mark = 1; - } -#endif - /* else it's already marked (remember, this function is iterated - until marking stops) */ - } } return did_mark; } -struct pruning_closure -{ - int (*obj_marked_p) (Lisp_Object); -}; - -static int -pruning_mapper (CONST void *key, CONST void *contents, void *closure) -{ - Lisp_Object keytem, valuetem; - struct pruning_closure *fmh = (struct pruning_closure *) closure; - - /* This function is called over each pair in the hashtable. - We remove the pairs that aren't completely marked (everything - that is going to stay ought to have been marked already - by the finish_marking stage). */ - CVOID_TO_LISP (keytem, key); - CVOID_TO_LISP (valuetem, contents); - - return ! ((*fmh->obj_marked_p) (keytem) && - (*fmh->obj_marked_p) (valuetem)); -} - void -prune_weak_hashtables (int (*obj_marked_p) (Lisp_Object)) +prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object)) { - Lisp_Object rest, prev = Qnil; - for (rest = Vall_weak_hashtables; - !GC_NILP (rest); - rest = XHASHTABLE (rest)->next_weak) + Lisp_Object hash_table, prev = Qnil; + for (hash_table = Vall_weak_hash_tables; + !GC_NILP (hash_table); + hash_table = XHASH_TABLE (hash_table)->next_weak) { - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (hash_table)) { - /* This table itself is garbage. Remove it from the list. */ + /* This hash table itself is garbage. Remove it from the list. */ if (GC_NILP (prev)) - Vall_weak_hashtables = XHASHTABLE (rest)->next_weak; + Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak; else - XHASHTABLE (prev)->next_weak = XHASHTABLE (rest)->next_weak; + XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak; } else { - struct pruning_closure fmh; - fmh.obj_marked_p = obj_marked_p; /* Now, scan over all the pairs. Remove all of the pairs in which the key or value, or both, is unmarked - (depending on the type of weak hashtable). */ - elisp_map_remhash (pruning_mapper, rest, &fmh); - prev = rest; + (depending on the type of weak hash table). */ + Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); + hentry *entries = ht->hentries; + hentry *sentinel = entries + ht->size; + hentry *e; + + for (e = entries; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + again: + if (!obj_marked_p (e->key) || !obj_marked_p (e->value)) + { + remhash_1 (ht, entries, e); + if (!HENTRY_CLEAR_P (e)) + goto again; + } + } + + prev = hash_table; } } } /* Return a hash value for an array of Lisp_Objects of size SIZE. */ -unsigned long +hashcode_t internal_array_hash (Lisp_Object *arr, int size, int depth) { int i; @@ -1194,7 +1286,7 @@ internal_array_hash (Lisp_Object *arr, int size, int depth) we could still take 5^5 time (a big big number) to compute a hash, but practically this won't ever happen. */ -unsigned long +hashcode_t internal_hash (Lisp_Object obj, int depth) { if (depth > 5) @@ -1206,21 +1298,23 @@ internal_hash (Lisp_Object obj, int depth) return HASH2 (internal_hash (XCAR (obj), depth + 1), internal_hash (XCDR (obj), depth + 1)); } - else if (STRINGP (obj)) - return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); - else if (VECTORP (obj)) + if (STRINGP (obj)) + { + return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); + } + if (VECTORP (obj)) { - struct Lisp_Vector *v = XVECTOR (obj); - return HASH2 (vector_length (v), - internal_array_hash (v->contents, vector_length (v), + return HASH2 (XVECTOR_LENGTH (obj), + internal_array_hash (XVECTOR_DATA (obj), + XVECTOR_LENGTH (obj), depth + 1)); } - else if (LRECORDP (obj)) + if (LRECORDP (obj)) { CONST struct lrecord_implementation *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); if (imp->hash) - return (imp->hash) (obj, depth); + return imp->hash (obj, depth); } return LISP_HASH (obj); @@ -1247,34 +1341,44 @@ The value is returned as (HIGH . LOW). void syms_of_elhash (void) { - DEFSUBR (Fmake_hashtable); - DEFSUBR (Fcopy_hashtable); - DEFSUBR (Fhashtablep); + DEFSUBR (Fhash_table_p); + DEFSUBR (Fmake_hash_table); + DEFSUBR (Fcopy_hash_table); DEFSUBR (Fgethash); - DEFSUBR (Fputhash); DEFSUBR (Fremhash); + DEFSUBR (Fputhash); DEFSUBR (Fclrhash); DEFSUBR (Fmaphash); - DEFSUBR (Fhashtable_fullness); - DEFSUBR (Fhashtable_type); - DEFSUBR (Fhashtable_test_function); - DEFSUBR (Fmake_weak_hashtable); - DEFSUBR (Fmake_key_weak_hashtable); - DEFSUBR (Fmake_value_weak_hashtable); + DEFSUBR (Fhash_table_count); + DEFSUBR (Fhash_table_size); + DEFSUBR (Fhash_table_rehash_size); + DEFSUBR (Fhash_table_rehash_threshold); + DEFSUBR (Fhash_table_type); + DEFSUBR (Fhash_table_test); #if 0 DEFSUBR (Finternal_hash_value); #endif - defsymbol (&Qhashtablep, "hashtablep"); + + defsymbol (&Qhash_tablep, "hash-table-p"); + defsymbol (&Qhash_table, "hash-table"); defsymbol (&Qhashtable, "hashtable"); defsymbol (&Qweak, "weak"); defsymbol (&Qkey_weak, "key-weak"); defsymbol (&Qvalue_weak, "value-weak"); defsymbol (&Qnon_weak, "non-weak"); + defsymbol (&Qrehash_size, "rehash-size"); + defsymbol (&Qrehash_threshold, "rehash-threshold"); + + defkeyword (&Q_size, ":size"); + defkeyword (&Q_test, ":test"); + defkeyword (&Q_type, ":type"); + defkeyword (&Q_rehash_size, ":rehash-size"); + defkeyword (&Q_rehash_threshold, ":rehash-threshold"); } void vars_of_elhash (void) { /* This must NOT be staticpro'd */ - Vall_weak_hashtables = Qnil; + Vall_weak_hash_tables = Qnil; } diff --git a/src/elhash.h b/src/elhash.h index 1551fa3..982a729 100644 --- a/src/elhash.h +++ b/src/elhash.h @@ -23,56 +23,64 @@ Boston, MA 02111-1307, USA. */ #ifndef _XEMACS_ELHASH_H_ #define _XEMACS_ELHASH_H_ -DECLARE_LRECORD (hashtable, struct hashtable); +DECLARE_LRECORD (hash_table, struct Lisp_Hash_Table); -#define XHASHTABLE(x) XRECORD (x, hashtable, struct hashtable) -#define XSETHASHTABLE(x, p) XSETRECORD (x, p, hashtable) -#define HASHTABLEP(x) RECORDP (x, hashtable) -#define GC_HASHTABLEP(x) GC_RECORDP (x, hashtable) -#define CHECK_HASHTABLE(x) CHECK_RECORD (x, hashtable) -#define CONCHECK_HASHTABLE(x) CONCHECK_RECORD (x, hashtable) +#define XHASH_TABLE(x) XRECORD (x, hash_table, struct Lisp_Hash_Table) +#define XSETHASH_TABLE(x, p) XSETRECORD (x, p, hash_table) +#define HASH_TABLEP(x) RECORDP (x, hash_table) +#define GC_HASH_TABLEP(x) GC_RECORDP (x, hash_table) +#define CHECK_HASH_TABLE(x) CHECK_RECORD (x, hash_table) +#define CONCHECK_HASH_TABLE(x) CONCHECK_RECORD (x, hash_table) -enum hashtable_type +enum hash_table_type { - HASHTABLE_NONWEAK, - HASHTABLE_KEY_WEAK, - HASHTABLE_VALUE_WEAK, - HASHTABLE_KEY_CAR_WEAK, - HASHTABLE_VALUE_CAR_WEAK, - HASHTABLE_WEAK + HASH_TABLE_NON_WEAK, + HASH_TABLE_KEY_WEAK, + HASH_TABLE_VALUE_WEAK, + HASH_TABLE_KEY_CAR_WEAK, + HASH_TABLE_VALUE_CAR_WEAK, + HASH_TABLE_WEAK }; -enum hashtable_test_fun +enum hash_table_test { - HASHTABLE_EQ, - HASHTABLE_EQL, - HASHTABLE_EQUAL + HASH_TABLE_EQ, + HASH_TABLE_EQL, + HASH_TABLE_EQUAL }; -EXFUN (Fcopy_hashtable, 1); -EXFUN (Fhashtable_fullness, 1); +EXFUN (Fcopy_hash_table, 1); +EXFUN (Fhash_table_count, 1); +EXFUN (Fgethash, 3); +EXFUN (Fputhash, 3); EXFUN (Fremhash, 2); +EXFUN (Fclrhash, 1); -Lisp_Object make_lisp_hashtable (int size, - enum hashtable_type type, - enum hashtable_test_fun test_fun); +typedef unsigned long hashcode_t; +typedef int (*hash_table_test_function_t) (Lisp_Object obj1, Lisp_Object obj2); +typedef unsigned long (*hash_table_hash_function_t) (Lisp_Object obj); +typedef int (*maphash_function_t) (Lisp_Object key, Lisp_Object value, + void* extra_arg); -void elisp_maphash (int (*fn) (CONST void *key, void *contents, - void *extra_arg), - Lisp_Object table, - void *extra_arg); -void elisp_map_remhash (int (*fn) (CONST void *key, - CONST void *contents, - void *extra_arg), - Lisp_Object table, - void *extra_arg); +Lisp_Object make_general_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test, + double rehash_threshold, + double rehash_size); -int finish_marking_weak_hashtables (int (*obj_marked_p) (Lisp_Object), - void (*markobj) (Lisp_Object)); -void prune_weak_hashtables (int (*obj_marked_p) (Lisp_Object)); +Lisp_Object make_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test); -void *elisp_hvector_malloc (unsigned int, Lisp_Object); -void elisp_hvector_free (void *ptr, Lisp_Object table); +void elisp_maphash (maphash_function_t function, + Lisp_Object hash_table, void *extra_arg); + +void elisp_map_remhash (maphash_function_t predicate, + Lisp_Object hash_table, void *extra_arg); + +int finish_marking_weak_hash_tables (int (*obj_marked_p) (Lisp_Object), + void (*markobj) (Lisp_Object)); +void prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object)); #endif /* _XEMACS_ELHASH_H_ */ diff --git a/src/emacs.c b/src/emacs.c index 09de76b..89784aa 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -35,14 +35,18 @@ Boston, MA 02111-1307, USA. */ #include "commands.h" #include "console.h" #include "process.h" +#include "redisplay.h" #include "sysdep.h" -#include #include "syssignal.h" /* Always include before systty.h */ #include "systty.h" #include "sysfile.h" #include "systime.h" +#ifdef QUANTIFY +#include +#endif + #ifdef HAVE_SHLIB #include "sysdll.h" #endif @@ -212,8 +216,6 @@ int initial_argc; static void sort_args (int argc, char **argv); -extern int always_gc; /* hack */ - Lisp_Object Qkill_emacs_hook; Lisp_Object Qsave_buffers_kill_emacs; @@ -445,7 +447,7 @@ Return the directory name in which the Emacs executable was located. #endif #if defined (MULE) && defined (MSDOS) && defined (EMX) -/* Setup all of files be input/output'ed with binary translation mdoe. */ +/* Setup all of files be input/output'ed with binary translation mode. */ asm (" .text"); asm ("L_setbinmode:"); asm (" movl $1, __fmode_bin"); @@ -519,7 +521,10 @@ argmatch (char **argv, int argc, char *sstr, char *lstr, /* Make stack traces always identify version + configuration */ #define main_1 STACK_TRACE_EYE_CATCHER -static DOESNT_RETURN +/* This function is not static, so that the compiler is less likely to + inline it, which would make it not show up in stack traces. */ +DECLARE_DOESNT_RETURN (main_1 (int, char **, char **, int)); +DOESNT_RETURN main_1 (int argc, char **argv, char **envp, int restart) { char stack_bottom_variable; @@ -894,6 +899,9 @@ main_1 (int argc, char **argv, char **envp, int restart) syms_of_elhash (); syms_of_emacs (); syms_of_eval (); +#ifdef HAVE_X_WINDOWS + syms_of_event_Xt (); +#endif #ifdef HAVE_DRAGNDROP syms_of_dragdrop (); #endif @@ -964,12 +972,12 @@ main_1 (int argc, char **argv, char **envp, int restart) syms_of_device_tty (); syms_of_objects_tty (); #endif + #ifdef HAVE_X_WINDOWS syms_of_device_x (); #ifdef HAVE_DIALOGS syms_of_dialog_x (); #endif - syms_of_event_Xt (); syms_of_frame_x (); syms_of_glyphs_x (); syms_of_objects_x (); @@ -985,7 +993,6 @@ main_1 (int argc, char **argv, char **envp, int restart) #ifdef HAVE_MS_WINDOWS syms_of_console_mswindows (); syms_of_device_mswindows (); - syms_of_event_mswindows (); syms_of_frame_mswindows (); syms_of_objects_mswindows (); syms_of_select_mswindows (); @@ -1026,10 +1033,6 @@ main_1 (int argc, char **argv, char **envp, int restart) SYMS_MACHINE; #endif -#ifdef EMACS_BTL - syms_of_btl (); -#endif - /* #if defined (GNU_MALLOC) && \ defined (ERROR_CHECK_MALLOC) && \ @@ -1152,7 +1155,7 @@ main_1 (int argc, char **argv, char **envp, int restart) structure_type_create_chartab (); structure_type_create_faces (); structure_type_create_rangetab (); - structure_type_create_hashtable (); + structure_type_create_hash_table (); /* Now initialize the image instantiator formats and associated symbols. Other than the first function below, the functions may @@ -1189,7 +1192,7 @@ main_1 (int argc, char **argv, char **envp, int restart) #if defined (HAVE_MS_WINDOWS) && !defined(HAVE_MSG_SELECT) lstream_type_create_mswindows_selectable (); #endif - + /* Initialize processes implementation. The functions may make exactly the following function/macro calls: @@ -1276,7 +1279,18 @@ main_1 (int argc, char **argv, char **envp, int restart) vars_of_elhash (); vars_of_emacs (); vars_of_eval (); + +#ifdef HAVE_X_WINDOWS + vars_of_event_Xt (); +#endif +#if defined(HAVE_TTY) && (defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS)) + vars_of_event_tty (); +#endif +#ifdef HAVE_MS_WINDOWS + vars_of_event_mswindows (); +#endif vars_of_event_stream (); + vars_of_events (); vars_of_extents (); vars_of_faces (); @@ -1345,7 +1359,6 @@ main_1 (int argc, char **argv, char **envp, int restart) #ifdef HAVE_TTY vars_of_console_tty (); - vars_of_event_tty (); vars_of_frame_tty (); vars_of_objects_tty (); #endif @@ -1355,7 +1368,6 @@ main_1 (int argc, char **argv, char **envp, int restart) #ifdef HAVE_DIALOGS vars_of_dialog_x (); #endif - vars_of_event_Xt (); vars_of_frame_x (); vars_of_glyphs_x (); #ifdef HAVE_MENUBARS @@ -1374,7 +1386,6 @@ main_1 (int argc, char **argv, char **envp, int restart) #ifdef HAVE_MS_WINDOWS vars_of_device_mswindows (); vars_of_console_mswindows (); - vars_of_event_mswindows (); vars_of_frame_mswindows (); vars_of_objects_mswindows (); vars_of_select_mswindows (); @@ -1458,14 +1469,14 @@ main_1 (int argc, char **argv, char **envp, int restart) /* Calls Fmake_range_table(). */ complex_vars_of_search (); - /* Calls make_lisp_hashtable(). */ + /* Calls make_lisp_hash_table(). */ complex_vars_of_extents (); - /* Depends on hashtables and specifiers. */ + /* Depends on hash tables and specifiers. */ complex_vars_of_faces (); #ifdef MULE - /* These two depend on hashtables and various variables declared + /* These two depend on hash tables and various variables declared earlier. The second may also depend on the first. */ complex_vars_of_mule_charset (); #endif @@ -1536,15 +1547,21 @@ main_1 (int argc, char **argv, char **envp, int restart) complex_vars_of_emacs (); /* This creates a couple of basic keymaps and depends on Lisp - hashtables and Ffset() (both of which depend on some variables + hash tables and Ffset() (both of which depend on some variables initialized in the vars_of_*() section) and possibly other stuff. */ complex_vars_of_keymap (); - /* Calls Fmake_hashtable() and creates a keymap */ + + /* Calls make_lisp_hash_table() and creates a keymap */ complex_vars_of_event_stream (); - if (always_gc) /* purification debugging hack */ - garbage_collect_1 (); +#ifdef ERROR_CHECK_GC + { + extern int always_gc; + if (always_gc) /* purification debugging hack */ + garbage_collect_1 (); + } +#endif } /* CONGRATULATIONS!!! We have successfully initialized the Lisp @@ -1574,7 +1591,7 @@ main_1 (int argc, char **argv, char **envp, int restart) #ifdef WINDOWSNT /* * For Win32, call init_environment() now, so that environment/registry - * variables will be properly entered into Vprocess_envonment. + * variables will be properly entered into Vprocess_environment. */ init_environment(); #endif @@ -1657,11 +1674,11 @@ main_1 (int argc, char **argv, char **envp, int restart) char *buf = (char *)alloca (XSTRING_LENGTH (Vinvocation_directory) + XSTRING_LENGTH (Vinvocation_name) + 2); - sprintf (buf, "%s/%s", XSTRING_DATA(Vinvocation_directory), - XSTRING_DATA(Vinvocation_name)); + sprintf (buf, "%s/%s", XSTRING_DATA (Vinvocation_directory), + XSTRING_DATA (Vinvocation_name)); /* All we can do is cry if an error happens, so ignore it. */ - (void)dll_init(buf); + (void) dll_init (buf); } #endif @@ -1791,7 +1808,7 @@ static struct standard_args standard_args[] = static void sort_args (int argc, char **argv) { - char **new = xnew_array (char *, argc); + char **new_argv = xnew_array (char *, argc); /* For each element of argv, the corresponding element of options is: 0 for an option that takes no arguments, @@ -1871,8 +1888,8 @@ sort_args (int argc, char **argv) } } - /* Copy the arguments, in order of decreasing priority, to NEW. */ - new[0] = argv[0]; + /* Copy the arguments, in order of decreasing priority, to NEW_ARGV. */ + new_argv[0] = argv[0]; while (to < argc) { int best = -1; @@ -1895,10 +1912,10 @@ sort_args (int argc, char **argv) if (best < 0) abort (); - /* Copy the highest priority remaining option, with its args, to NEW. */ - new[to++] = argv[best]; + /* Copy the highest priority remaining option, with its args, to NEW_ARGV. */ + new_argv[to++] = argv[best]; for (i = 0; i < options[best]; i++) - new[to++] = argv[best + i + 1]; + new_argv[to++] = argv[best + i + 1]; /* Clear out this option in ARGV. */ argv[best] = 0; @@ -1906,7 +1923,10 @@ sort_args (int argc, char **argv) argv[best + i + 1] = 0; } - memcpy (argv, new, sizeof (char *) * argc); + memcpy (argv, new_argv, sizeof (char *) * argc); + xfree (new_argv); + xfree (options); + xfree (priority); } static JMP_BUF run_temacs_catch; @@ -1938,7 +1958,9 @@ Do not call this. It will reinitialize your XEmacs. You'll be sorry. a dumped version in case you want to rerun it. This function is most useful when used as part of the `make all-elc' command. --ben] This will "restart" emacs with the specified command-line arguments. - */ + + Martin thinks this function is most useful when using debugging + tools like Purify or tcov that get confused by XEmacs' dumping. */ (int nargs, Lisp_Object *args)) { int ac; @@ -1988,11 +2010,13 @@ Do not call this. It will reinitialize your XEmacs. You'll be sorry. unbind_to (0, Qnil); /* this closes loadup.el */ purify_flag = 0; run_temacs_argc = nargs + 1; +#if 0 #ifdef REPORT_PURE_USAGE report_pure_usage (1, 0); #else report_pure_usage (0, 0); #endif +#endif /* 0 */ LONGJMP (run_temacs_catch, 1); return Qnil; /* not reached; warning suppression */ } @@ -2004,28 +2028,33 @@ main (int argc, char **argv, char **envp) int volatile vol_argc = argc; char ** volatile vol_argv = argv; char ** volatile vol_envp = envp; - /* This is hairy. We need to compute where the XEmacs binary was invoked */ - /* from because temacs initialization requires it to find the lisp */ - /* directories. The code that recomputes the path is guarded by the */ - /* restarted flag. There are three possible paths I've found so far */ - /* through this: */ - /* temacs -- When running temacs for basic build stuff, the first main_1 */ - /* will be the only one invoked. It must compute the path else there */ - /* will be a very ugly bomb in startup.el (can't find obvious location */ - /* for doc-directory data-directory, etc.). */ - /* temacs w/ run-temacs on the command line -- This is run to bytecompile */ - /* all the out of date dumped lisp. It will execute both of the main_1 */ - /* calls and the second one must not touch the first computation because */ - /* argc/argv are hosed the second time through. */ - /* xemacs -- Only the second main_1 is executed. The invocation path must */ - /* computed but this only matters when running in place or when running */ - /* as a login shell. */ - /* As a bonus for straightening this out, XEmacs can now be run in place */ - /* as a login shell. This never used to work. */ - /* As another bonus, we can now guarantee that */ - /* (concat invocation-directory invocation-name) contains the filename */ - /* of the XEmacs binary we are running. This can now be used in a */ - /* definite test for out of date dumped files. -slb */ + /* This is hairy. We need to compute where the XEmacs binary was invoked + from because temacs initialization requires it to find the lisp + directories. The code that recomputes the path is guarded by the + restarted flag. There are three possible paths I've found so far + through this: + + temacs -- When running temacs for basic build stuff, the first main_1 + will be the only one invoked. It must compute the path else there + will be a very ugly bomb in startup.el (can't find obvious location + for doc-directory data-directory, etc.). + + temacs w/ run-temacs on the command line -- This is run to bytecompile + all the out of date dumped lisp. It will execute both of the main_1 + calls and the second one must not touch the first computation because + argc/argv are hosed the second time through. + + xemacs -- Only the second main_1 is executed. The invocation path must + computed but this only matters when running in place or when running + as a login shell. + + As a bonus for straightening this out, XEmacs can now be run in place + as a login shell. This never used to work. + + As another bonus, we can now guarantee that + (concat invocation-directory invocation-name) contains the filename + of the XEmacs binary we are running. This can now be used in a + definite test for out of date dumped files. -slb */ int restarted = 0; #ifdef QUANTIFY quantify_stop_recording_data (); @@ -2080,7 +2109,7 @@ main (int argc, char **argv, char **envp) } #ifdef RUN_TIME_REMAP else - /* obviously no-one uses this because where it was before initalized was + /* obviously no-one uses this because where it was before initialized was *always* true */ run_time_remap (argv[0]); #endif @@ -2449,10 +2478,10 @@ and announce itself normally when it is run. It's a whole lot easier to do the conversion here than to modify all the unexec routines to ensure that filename conversion is applied everywhere. Don't worry about memory - leakage because this call only happens once. */ - unexec (intoname_ext, symname_ext, (uintptr_t) my_edata, 0, 0); + leakage because this call only happens once. */ + unexec (intoname_ext, symname_ext, (uintptr_t) my_edata, 0, 0); #ifdef DOUG_LEA_MALLOC - free (malloc_state_ptr); + free (malloc_state_ptr); #endif } #endif /* not MSDOS and EMX */ @@ -2605,7 +2634,7 @@ assert_failed (CONST char *file, int line, CONST char *expr) #ifdef QUANTIFY DEFUN ("quantify-start-recording-data", Fquantify_start_recording_data, - 0, 0, 0, /* + 0, 0, "", /* Start recording Quantify data. */ ()) @@ -2615,7 +2644,7 @@ Start recording Quantify data. } DEFUN ("quantify-stop-recording-data", Fquantify_stop_recording_data, - 0, 0, 0, /* + 0, 0, "", /* Stop recording Quantify data. */ ()) @@ -2624,7 +2653,7 @@ Stop recording Quantify data. return Qnil; } -DEFUN ("quantify-clear-data", Fquantify_clear_data, 0, 0, 0, /* +DEFUN ("quantify-clear-data", Fquantify_clear_data, 0, 0, "", /* Clear all Quantify data. */ ()) @@ -2857,7 +2886,7 @@ void complex_vars_of_emacs (void) { /* This is all related to path searching. */ - + DEFVAR_LISP ("emacs-program-name", &Vemacs_program_name /* *Name of the Emacs variant. For example, this may be \"xemacs\" or \"infodock\". diff --git a/src/eval.c b/src/eval.c index cd28827..0f07512 100644 --- a/src/eval.c +++ b/src/eval.c @@ -21,10 +21,6 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ -/* Debugging hack */ -int always_gc; - - #include #include "lisp.h" @@ -35,17 +31,68 @@ int always_gc; #include "console.h" #include "opaque.h" +#ifdef ERROR_CHECK_GC +int always_gc; /* Debugging hack */ +#else +#define always_gc 0 +#endif + struct backtrace *backtrace_list; -/* Note you must always fill all of the fields in a backtrace structure +/* Note: you must always fill in all of the fields in a backtrace structure before pushing them on the backtrace_list. The profiling code depends on this. */ -#define PUSH_BACKTRACE(bt) \ - do { (bt).next = backtrace_list; backtrace_list = &(bt); } while (0) +#define PUSH_BACKTRACE(bt) do { \ + (bt).next = backtrace_list; \ + backtrace_list = &(bt); \ +} while (0) + +#define POP_BACKTRACE(bt) do { \ + backtrace_list = (bt).next; \ +} while (0) + +/* Macros for calling subrs with an argument list whose length is only + known at runtime. See EXFUN and DEFUN for similar hackery. */ + +#define AV_0(av) +#define AV_1(av) av[0] +#define AV_2(av) AV_1(av), av[1] +#define AV_3(av) AV_2(av), av[2] +#define AV_4(av) AV_3(av), av[3] +#define AV_5(av) AV_4(av), av[4] +#define AV_6(av) AV_5(av), av[5] +#define AV_7(av) AV_6(av), av[6] +#define AV_8(av) AV_7(av), av[7] + +#define PRIMITIVE_FUNCALL_1(fn, av, ac) \ +(((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) + +/* If subrs take more than 8 arguments, more cases need to be added + to this switch. (But wait - don't do it - if you really need + a SUBR with more than 8 arguments, use max_args == MANY. + See the DEFUN macro in lisp.h) */ +#define PRIMITIVE_FUNCALL(rv, fn, av, ac) do { \ + void (*PF_fn)() = (void (*)()) (fn); \ + Lisp_Object *PF_av = (av); \ + switch (ac) \ + { \ + default: abort(); \ + case 0: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break; \ + case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break; \ + case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break; \ + case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break; \ + case 4: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 4); break; \ + case 5: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 5); break; \ + case 6: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 6); break; \ + case 7: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 7); break; \ + case 8: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 8); break; \ + } \ +} while (0) + +#define FUNCALL_SUBR(rv, subr, av, ac) \ + PRIMITIVE_FUNCALL (rv, subr_function (subr), av, ac); -#define POP_BACKTRACE(bt) \ - do { backtrace_list = (bt).next; } while (0) /* This is the list of current catches (and also condition-cases). This is a stack: the most recent catch is at the head of the @@ -80,6 +127,7 @@ Lisp_Object Qrun_hooks; Lisp_Object Qsetq; Lisp_Object Qdisplay_warning; Lisp_Object Vpending_warnings, Vpending_warnings_tail; +Lisp_Object Qif; /* Records whether we want errors to occur. This will be a boolean, nil (errors OK) or t (no errors). If t, an error will cause a @@ -104,11 +152,10 @@ int preparing_for_armageddon; if the file being autoloaded is not fully loaded. They are recorded by being consed onto the front of Vautoload_queue: (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ - Lisp_Object Vautoload_queue; /* Current number of specbindings allocated in specpdl. */ -static int specpdl_size; +int specpdl_size; /* Pointer to beginning of specpdl. */ struct specbinding *specpdl; @@ -116,9 +163,8 @@ struct specbinding *specpdl; /* Pointer to first unused element in specpdl. */ struct specbinding *specpdl_ptr; -/* specpdl_ptr - specpdl. Callers outside this file should use - * specpdl_depth () function-call */ -static int specpdl_depth_counter; +/* specpdl_ptr - specpdl */ +int specpdl_depth_counter; /* Maximum size allowed for specpdl allocation */ int max_specpdl_size; @@ -221,95 +267,44 @@ Lisp_Object Vdebugger; */ static Lisp_Object Vcondition_handlers; + +#if 0 /* no longer used */ /* Used for error catching purposes by throw_or_bomb_out */ static int throw_level; - -static Lisp_Object primitive_funcall (lisp_fn_t fn, int nargs, - Lisp_Object args[]); +#endif /* unused */ -/**********************************************************************/ -/* The subr and compiled-function types */ -/**********************************************************************/ +/************************************************************************/ +/* The subr object type */ +/************************************************************************/ static void print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - struct Lisp_Subr *subr = XSUBR (obj); + Lisp_Subr *subr = XSUBR (obj); + CONST char *header = + (subr->max_args == UNEVALLED) ? "#prompt ? " (interactive)>" : ">"; if (print_readably) - error ("printing unreadable object #", - subr_name (subr)); + error ("printing unreadable object %s%s%s", header, name, trailer); - write_c_string (((subr->max_args == UNEVALLED) - ? "#prompt) ? " (interactive)>" : ">"), - printcharfun); + write_c_string (header, printcharfun); + write_c_string (name, printcharfun); + write_c_string (trailer, printcharfun); } DEFINE_LRECORD_IMPLEMENTATION ("subr", subr, this_one_is_unmarkable, print_subr, 0, 0, 0, - struct Lisp_Subr); - -static Lisp_Object -mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) -{ - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); - - ((markobj) (b->bytecodes)); - ((markobj) (b->arglist)); - ((markobj) (b->doc_and_interactive)); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - ((markobj) (b->annotated)); -#endif - /* tail-recurse on constants */ - return b->constants; -} - -static int -compiled_function_equal (Lisp_Object o1, Lisp_Object o2, int depth) -{ - struct Lisp_Compiled_Function *b1 = XCOMPILED_FUNCTION (o1); - struct Lisp_Compiled_Function *b2 = XCOMPILED_FUNCTION (o2); - return - (b1->flags.documentationp == b2->flags.documentationp && - b1->flags.interactivep == b2->flags.interactivep && - b1->flags.domainp == b2->flags.domainp && /* I18N3 */ - internal_equal (b1->bytecodes, b2->bytecodes, depth + 1) && - internal_equal (b1->constants, b2->constants, depth + 1) && - internal_equal (b1->arglist, b2->arglist, depth + 1) && - internal_equal (b1->doc_and_interactive, - b2->doc_and_interactive, depth + 1)); -} - -static unsigned long -compiled_function_hash (Lisp_Object obj, int depth) -{ - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); - return HASH3 ((b->flags.documentationp << 2) + - (b->flags.interactivep << 1) + - b->flags.domainp, - internal_hash (b->bytecodes, depth + 1), - internal_hash (b->constants, depth + 1)); -} - -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, - mark_compiled_function, - print_compiled_function, 0, - compiled_function_equal, - compiled_function_hash, - struct Lisp_Compiled_Function); + Lisp_Subr); -/**********************************************************************/ -/* Entering the debugger */ -/**********************************************************************/ +/************************************************************************/ +/* Entering the debugger */ +/************************************************************************/ /* unwind-protect used by call_debugger() to restore the value of - enterring_debugger. (We cannot use specbind() because the + entering_debugger. (We cannot use specbind() because the variable is not Lisp-accessible.) */ static Lisp_Object @@ -337,12 +332,12 @@ call_debugger_259 (Lisp_Object arg) } /* Call the debugger, doing some encapsulation. We make sure we have - some room on the eval and specpdl stacks, and bind enterring_debugger + some room on the eval and specpdl stacks, and bind entering_debugger to 1 during this call. This is used to trap errors that may occur - when enterring the debugger (e.g. the value of `debugger' is invalid), + when entering the debugger (e.g. the value of `debugger' is invalid), so that the debugger will not be recursively entered if debug-on-error is set. (Otherwise, XEmacs would infinitely recurse, attempting to - enter the debugger.) enterring_debugger gets reset to 0 as soon + enter the debugger.) entering_debugger gets reset to 0 as soon as a backtrace is displayed, so that further errors can indeed be handled normally. @@ -383,7 +378,7 @@ call_debugger (Lisp_Object arg) max_specpdl_size = specpdl_size + 40; debug_on_next_call = 0; - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); record_unwind_protect (restore_entering_debugger, (entering_debugger ? Qt : Qnil)); entering_debugger = 1; @@ -542,7 +537,7 @@ signal_call_debugger (Lisp_Object conditions, Lisp_Object val = Qunbound; Lisp_Object all_handlers = Vcondition_handlers; Lisp_Object temp_data = Qnil; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); struct gcpro gcpro1, gcpro2; GCPRO2 (all_handlers, temp_data); @@ -554,12 +549,12 @@ signal_call_debugger (Lisp_Object conditions, && wants_debugger (Vstack_trace_on_error, conditions) && !skip_debugger (conditions, temp_data)) { - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); - internal_with_output_to_temp_buffer ("*Backtrace*", + internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), backtrace_259, Qnil, Qnil); @@ -574,9 +569,9 @@ signal_call_debugger (Lisp_Object conditions, && !skip_debugger (conditions, temp_data)) { debug_on_quit &= ~2; /* reset critical bit */ - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); @@ -586,12 +581,12 @@ signal_call_debugger (Lisp_Object conditions, if (!entering_debugger && !*stack_trace_displayed && wants_debugger (Vstack_trace_on_signal, conditions)) { - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); - internal_with_output_to_temp_buffer ("*Backtrace*", + internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), backtrace_259, Qnil, Qnil); @@ -605,9 +600,9 @@ signal_call_debugger (Lisp_Object conditions, : wants_debugger (Vdebug_on_signal, conditions))) { debug_on_quit &= ~2; /* reset critical bit */ - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); @@ -620,13 +615,12 @@ signal_call_debugger (Lisp_Object conditions, } -/**********************************************************************/ -/* The basic special forms */ -/**********************************************************************/ +/************************************************************************/ +/* The basic special forms */ +/************************************************************************/ -/* NOTE!!! Every function that can call EVAL must protect its args - and temporaries from garbage collection while it needs them. - The definition of `For' shows what you have to do. */ +/* Except for Fprogn(), the basic special forms below are only called + from interpreted code. The byte compiler turns them into bytecodes. */ DEFUN ("or", For, 0, UNEVALLED, 0, /* Eval args until one of them yields non-nil, then return that value. @@ -636,22 +630,14 @@ If all args return nil, return nil. (args)) { /* This function can GC */ - REGISTER Lisp_Object tail; - struct gcpro gcpro1; + REGISTER Lisp_Object arg, val; - GCPRO1 (args); - - LIST_LOOP (tail, args) + LIST_LOOP_2 (arg, args) { - Lisp_Object val = Feval (XCAR (tail)); - if (!NILP (val)) - { - UNGCPRO; - return val; - } + if (!NILP (val = Feval (arg))) + return val; } - UNGCPRO; return Qnil; } @@ -663,19 +649,14 @@ If no arg yields nil, return the last arg's value. (args)) { /* This function can GC */ - REGISTER Lisp_Object tail, val = Qt; - struct gcpro gcpro1; + REGISTER Lisp_Object arg, val = Qt; - GCPRO1 (args); - - LIST_LOOP (tail, args) + LIST_LOOP_2 (arg, args) { - val = Feval (XCAR (tail)); - if (NILP (val)) - break; + if (NILP (val = Feval (arg))) + return val; } - UNGCPRO; return val; } @@ -688,18 +669,47 @@ If COND yields nil, and there are no ELSE's, the value is nil. (args)) { /* This function can GC */ - Lisp_Object val; - struct gcpro gcpro1; - - GCPRO1 (args); + Lisp_Object condition = XCAR (args); + Lisp_Object then_form = XCAR (XCDR (args)); + Lisp_Object else_forms = XCDR (XCDR (args)); - if (!NILP (Feval (XCAR (args)))) - val = Feval (XCAR (XCDR ((args)))); + if (!NILP (Feval (condition))) + return Feval (then_form); else - val = Fprogn (XCDR (XCDR (args))); + return Fprogn (else_forms); +} - UNGCPRO; - return val; +/* Macros `when' and `unless' are trivially defined in Lisp, + but it helps for bootstrapping to have them ALWAYS defined. */ + +DEFUN ("when", Fwhen, 1, MANY, 0, /* +\(when COND BODY...): if COND yields non-nil, do BODY, else return nil. +BODY can be zero or more expressions. If BODY is nil, return nil. +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object cond = args[0]; + Lisp_Object body; + + switch (nargs) + { + case 1: body = Qnil; break; + case 2: body = args[1]; break; + default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; + } + + return list3 (Qif, cond, body); +} + +DEFUN ("unless", Funless, 1, MANY, 0, /* +\(unless COND BODY...): if COND yields nil, do BODY, else return nil. +BODY can be zero or more expressions. If BODY is nil, return nil. +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object cond = args[0]; + Lisp_Object body = Flist (nargs-1, args+1); + return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); } DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* @@ -715,30 +725,21 @@ CONDITION's value if non-nil is returned from the cond-form. (args)) { /* This function can GC */ - REGISTER Lisp_Object tail; - struct gcpro gcpro1; - - GCPRO1 (args); + REGISTER Lisp_Object val, clause; - LIST_LOOP (tail, args) + LIST_LOOP_2 (clause, args) { - Lisp_Object val; - Lisp_Object clause = XCAR (tail); CHECK_CONS (clause); - val = Feval (XCAR (clause)); - if (!NILP (val)) + if (!NILP (val = Feval (XCAR (clause)))) { - Lisp_Object clause_tail = XCDR (clause); - if (!NILP (clause_tail)) + if (!NILP (clause = XCDR (clause))) { - CHECK_TRUE_LIST (clause_tail); - val = Fprogn (clause_tail); + CHECK_TRUE_LIST (clause); + val = Fprogn (clause); } - UNGCPRO; return val; } } - UNGCPRO; return Qnil; } @@ -749,61 +750,70 @@ DEFUN ("progn", Fprogn, 0, UNEVALLED, 0, /* (args)) { /* This function can GC */ - REGISTER Lisp_Object tail, val = Qnil; + /* Caller must provide a true list in ARGS */ + REGISTER Lisp_Object form, val = Qnil; struct gcpro gcpro1; GCPRO1 (args); - LIST_LOOP (tail, args) - val = Feval (XCAR (tail)); + { + LIST_LOOP_2 (form, args) + val = Feval (form); + } UNGCPRO; return val; } +/* Fprog1() is the canonical example of a function that must GCPRO a + Lisp_Object across calls to Feval(). */ + DEFUN ("prog1", Fprog1, 1, UNEVALLED, 0, /* -\(prog1 FIRST BODY...): eval FIRST and BODY sequentially; value from FIRST. -The value of FIRST is saved during the evaluation of the remaining args, +Similar to `progn', but the value of the first form is returned. +\(prog1 FIRST BODY...): All the arguments are evaluated sequentially. +The value of FIRST is saved during evaluation of the remaining args, whose values are discarded. */ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail = args; - Lisp_Object val = Qnil; - struct gcpro gcpro1, gcpro2; + REGISTER Lisp_Object val, form; + struct gcpro gcpro1; - GCPRO2 (args, val); + val = Feval (XCAR (args)); - val = Feval (XCAR (tail)); + GCPRO1 (val); - LIST_LOOP (tail, XCDR (tail)) - Feval (XCAR (tail)); + { + LIST_LOOP_2 (form, XCDR (args)) + Feval (form); + } UNGCPRO; return val; } DEFUN ("prog2", Fprog2, 2, UNEVALLED, 0, /* -\(prog2 X Y BODY...): eval X, Y and BODY sequentially; value from Y. -The value of Y is saved during the evaluation of the remaining args, +Similar to `progn', but the value of the second form is returned. +\(prog2 FIRST SECOND BODY...): All the arguments are evaluated sequentially. +The value of SECOND is saved during evaluation of the remaining args, whose values are discarded. */ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail = args; - Lisp_Object val = Qnil; - struct gcpro gcpro1, gcpro2; + REGISTER Lisp_Object val, form, tail; + struct gcpro gcpro1; - GCPRO2 (args, val); + Feval (XCAR (args)); + args = XCDR (args); + val = Feval (XCAR (args)); + args = XCDR (args); - Feval (XCAR (tail)); - tail = XCDR (tail); - val = Feval (XCAR (tail)); + GCPRO1 (val); - LIST_LOOP (tail, XCDR (tail)) - Feval (XCAR (tail)); + LIST_LOOP_3 (form, args, tail) + Feval (form); UNGCPRO; return val; @@ -819,42 +829,35 @@ Each VALUEFORM can refer to the symbols already bound by this VARLIST. (args)) { /* This function can GC */ + Lisp_Object var, tail; Lisp_Object varlist = XCAR (args); - Lisp_Object tail; - int speccount = specpdl_depth_counter; - struct gcpro gcpro1; + Lisp_Object body = XCDR (args); + int speccount = specpdl_depth(); - GCPRO1 (args); - - EXTERNAL_LIST_LOOP (tail, varlist) + EXTERNAL_LIST_LOOP_3 (var, varlist, tail) { - Lisp_Object elt = XCAR (tail); - QUIT; - if (SYMBOLP (elt)) - specbind (elt, Qnil); + Lisp_Object symbol, value, tem; + if (SYMBOLP (var)) + symbol = var, value = Qnil; else { - Lisp_Object sym, form; - CHECK_CONS (elt); - sym = XCAR (elt); - elt = XCDR (elt); - if (NILP (elt)) - form = Qnil; + CHECK_CONS (var); + symbol = XCAR (var); + tem = XCDR (var); + if (NILP (tem)) + value = Qnil; else { - CHECK_CONS (elt); - form = XCAR (elt); - elt = XCDR (elt); - if (!NILP (elt)) + CHECK_CONS (tem); + value = Feval (XCAR (tem)); + if (!NILP (XCDR (tem))) signal_simple_error - ("`let' bindings can have only one value-form", - XCAR (tail)); + ("`let' bindings can have only one value-form", var); } - specbind (sym, Feval (form)); } + specbind (symbol, value); } - UNGCPRO; - return unbind_to (speccount, Fprogn (XCDR (args))); + return unbind_to (speccount, Fprogn (body)); } DEFUN ("let", Flet, 1, UNEVALLED, 0, /* @@ -867,61 +870,60 @@ All the VALUEFORMs are evalled before any symbols are bound. (args)) { /* This function can GC */ + Lisp_Object var, tail; Lisp_Object varlist = XCAR (args); - REGISTER Lisp_Object tail; + Lisp_Object body = XCDR (args); + int speccount = specpdl_depth(); Lisp_Object *temps; - int speccount = specpdl_depth_counter; - REGISTER int argnum = 0; - struct gcpro gcpro1, gcpro2; + int idx; + struct gcpro gcpro1; /* Make space to hold the values to give the bound variables. */ { - int varcount = 0; - EXTERNAL_LIST_LOOP (tail, varlist) - varcount++; + int varcount; + GET_EXTERNAL_LIST_LENGTH (varlist, varcount); temps = alloca_array (Lisp_Object, varcount); } /* Compute the values and store them in `temps' */ + GCPRO1 (*temps); + gcpro1.nvars = 0; - GCPRO2 (args, *temps); - gcpro2.nvars = 0; - - LIST_LOOP (tail, varlist) + idx = 0; + LIST_LOOP_3 (var, varlist, tail) { - Lisp_Object elt = XCAR (tail); - QUIT; - if (SYMBOLP (elt)) - temps[argnum++] = Qnil; + Lisp_Object *value = &temps[idx++]; + if (SYMBOLP (var)) + *value = Qnil; else { - CHECK_CONS (elt); - elt = XCDR (elt); - if (NILP (elt)) - temps[argnum++] = Qnil; + Lisp_Object tem; + CHECK_CONS (var); + tem = XCDR (var); + if (NILP (tem)) + *value = Qnil; else { - CHECK_CONS (elt); - temps[argnum++] = Feval (XCAR (elt)); - gcpro2.nvars = argnum; + CHECK_CONS (tem); + *value = Feval (XCAR (tem)); + gcpro1.nvars = idx; - if (!NILP (XCDR (elt))) + if (!NILP (XCDR (tem))) signal_simple_error - ("`let' bindings can have only one value-form", - XCAR (tail)); + ("`let' bindings can have only one value-form", var); } } } - UNGCPRO; - argnum = 0; - LIST_LOOP (tail, varlist) + idx = 0; + LIST_LOOP_3 (var, varlist, tail) { - Lisp_Object elt = XCAR (tail); - specbind (SYMBOLP (elt) ? elt : XCAR (elt), temps[argnum++]); + specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); } - return unbind_to (speccount, Fprogn (XCDR (args))); + UNGCPRO; + + return unbind_to (speccount, Fprogn (body)); } DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* @@ -932,20 +934,15 @@ until TEST returns nil. (args)) { /* This function can GC */ - Lisp_Object tem; Lisp_Object test = XCAR (args); Lisp_Object body = XCDR (args); - struct gcpro gcpro1, gcpro2; - GCPRO2 (test, body); - - while (tem = Feval (test), !NILP (tem)) + while (!NILP (Feval (test))) { QUIT; Fprogn (body); } - UNGCPRO; return Qnil; } @@ -961,34 +958,21 @@ The return value of the `setq' form is the value of the last VAL. (args)) { /* This function can GC */ + Lisp_Object symbol, tail, val = Qnil; + int nargs; struct gcpro gcpro1; - Lisp_Object val = Qnil; - GCPRO1 (args); + GET_LIST_LENGTH (args, nargs); - { - REGISTER int i = 0; - Lisp_Object args2; - for (args2 = args; !NILP (args2); args2 = XCDR (args2)) - { - i++; - /* - * uncomment the QUIT if there is some way a circular - * arglist can get in here. I think Feval or Fapply would - * spin first and the list would never get here. - */ - /* QUIT; */ - } - if (i & 1) /* Odd number of arguments? */ - Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int(i))); - } + if (nargs & 1) /* Odd number of arguments? */ + Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); - while (!NILP (args)) + GCPRO1 (val); + + PROPERTY_LIST_LOOP (tail, symbol, val, args) { - Lisp_Object sym = XCAR (args); - val = Feval (XCAR (XCDR (args))); - Fset (sym, val); - args = XCDR (XCDR (args)); + val = Feval (val); + Fset (symbol, val); } UNGCPRO; @@ -1014,9 +998,18 @@ In byte compilation, `function' causes its argument to be compiled. } -/**********************************************************************/ -/* Defining functions/variables */ -/**********************************************************************/ +/************************************************************************/ +/* Defining functions/variables */ +/************************************************************************/ +static Lisp_Object +define_function (Lisp_Object name, Lisp_Object defn) +{ + if (purify_flag) + defn = Fpurecopy (defn); + Ffset (name, defn); + LOADHIST_ATTACH (name); + return name; +} DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. @@ -1026,14 +1019,8 @@ See also the function `interactive'. (args)) { /* This function can GC */ - Lisp_Object fn_name = XCAR (args); - Lisp_Object defn = Fcons (Qlambda, XCDR (args)); - - if (purify_flag) - defn = Fpurecopy (defn); - Ffset (fn_name, defn); - LOADHIST_ATTACH (fn_name); - return fn_name; + return define_function (XCAR (args), + Fcons (Qlambda, XCDR (args))); } DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* @@ -1047,14 +1034,8 @@ and the result should be a form to be evaluated instead of the original. (args)) { /* This function can GC */ - Lisp_Object fn_name = XCAR (args); - Lisp_Object defn = Fcons (Qmacro, Fcons (Qlambda, XCDR (args))); - - if (purify_flag) - defn = Fpurecopy (defn); - Ffset (fn_name, defn); - LOADHIST_ATTACH (fn_name); - return fn_name; + return define_function (XCAR (args), + Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); } DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* @@ -1086,7 +1067,13 @@ In lisp-interaction-mode defvar is treated as defconst. Lisp_Object val = XCAR (args); if (NILP (Fdefault_boundp (sym))) - Fset_default (sym, Feval (val)); + { + struct gcpro gcpro1; + GCPRO1 (val); + val = Feval (val); + Fset_default (sym, val); + UNGCPRO; + } if (!NILP (args = XCDR (args))) { @@ -1134,9 +1121,14 @@ Since `defconst' unconditionally assigns the variable, { /* This function can GC */ Lisp_Object sym = XCAR (args); - Lisp_Object val = XCAR (args = XCDR (args)); + Lisp_Object val = Feval (XCAR (args = XCDR (args))); + struct gcpro gcpro1; - Fset_default (sym, Feval (val)); + GCPRO1 (val); + + Fset_default (sym, val); + + UNGCPRO; if (!NILP (args = XCDR (args))) { @@ -1170,21 +1162,20 @@ for the variable is `*'. */ (variable)) { - Lisp_Object documentation; + Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil); - documentation = Fget (variable, Qvariable_documentation, Qnil); - if (INTP (documentation) && XINT (documentation) < 0) - return Qt; - if ((STRINGP (documentation)) && - (string_byte (XSTRING (documentation), 0) == '*')) - return Qt; - /* If it is (STRING . INTEGER), a negative integer means a user variable. */ - if (CONSP (documentation) + return + ((INTP (documentation) && XINT (documentation) < 0) || + + ((STRINGP (documentation)) && + (string_byte (XSTRING (documentation), 0) == '*')) || + + /* If (STRING . INTEGER), a negative integer means a user variable. */ + (CONSP (documentation) && STRINGP (XCAR (documentation)) && INTP (XCDR (documentation)) - && XINT (XCDR (documentation)) < 0) - return Qt; - return Qnil; + && XINT (XCDR (documentation)) < 0)) ? + Qt : Qnil; } DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* @@ -1265,9 +1256,9 @@ definitions to shadow the loaded ones for use in file byte-compilation. } -/**********************************************************************/ -/* Non-local exits */ -/**********************************************************************/ +/************************************************************************/ +/* Non-local exits */ +/************************************************************************/ DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'. @@ -1279,13 +1270,9 @@ If a throw happens, it specifies the value to return from `catch'. (args)) { /* This function can GC */ - Lisp_Object tag; - struct gcpro gcpro1; - - GCPRO1 (args); - tag = Feval (XCAR (args)); - UNGCPRO; - return internal_catch (tag, Fprogn, XCDR (args), 0); + Lisp_Object tag = Feval (XCAR (args)); + Lisp_Object body = XCDR (args); + return internal_catch (tag, Fprogn, body, 0); } /* Set up a catch, then call C function FUNC on argument ARG. @@ -1311,7 +1298,7 @@ internal_catch (Lisp_Object tag, c.handlerlist = handlerlist; #endif c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = specpdl_depth_counter; + c.pdlcount = specpdl_depth(); #if 0 /* FSFmacs */ c.poll_suppress_count = async_timer_suppress_count; #endif @@ -1396,7 +1383,9 @@ unwind_to_catch (struct catchtag *c, Lisp_Object val) backtrace_list = c->backlist; lisp_eval_depth = c->lisp_eval_depth; +#if 0 /* no longer used */ throw_level = 0; +#endif LONGJMP (c->jmp, 1); } @@ -1490,18 +1479,16 @@ If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway. (args)) { /* This function can GC */ - Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fprogn, XCDR (args)); - val = Feval (XCAR (args)); - return unbind_to (speccount, val); + return unbind_to (speccount, Feval (XCAR (args))); } -/**********************************************************************/ -/* Signalling and trapping errors */ -/**********************************************************************/ +/************************************************************************/ +/* Signalling and trapping errors */ +/************************************************************************/ static Lisp_Object condition_bind_unwind (Lisp_Object loser) @@ -1599,7 +1586,7 @@ condition_case_1 (Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), Lisp_Object harg) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); struct catchtag c; struct gcpro gcpro1; @@ -1622,7 +1609,7 @@ condition_case_1 (Lisp_Object handlers, c.handlerlist = handlerlist; #endif c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = specpdl_depth_counter; + c.pdlcount = specpdl_depth(); #if 0 /* FSFmacs */ c.poll_suppress_count = async_timer_suppress_count; #endif @@ -1674,17 +1661,18 @@ run_condition_case_handlers (Lisp_Object val, Lisp_Object var) val = Fprogn (Fcdr (h.chosen_clause)); /* Note that this just undoes the binding of h.var; whoever - longjumped to us unwound the stack to c.pdlcount before + longjmp()ed to us unwound the stack to c.pdlcount before throwing. */ unbind_to (c.pdlcount, Qnil); return val; #else int speccount; + CHECK_TRUE_LIST (val); if (NILP (var)) - return Fprogn (Fcdr (val)); /* tailcall */ + return Fprogn (Fcdr (val)); /* tail call */ - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (var, Fcar (val)); val = Fprogn (Fcdr (val)); return unbind_to (speccount, val); @@ -1698,30 +1686,45 @@ Lisp_Object condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) { /* This function can GC */ - Lisp_Object val; + Lisp_Object handler; - CHECK_SYMBOL (var); - - for (val = handlers; ! NILP (val); val = Fcdr (val)) + EXTERNAL_LIST_LOOP_2 (handler, handlers) { - Lisp_Object tem; - tem = Fcar (val); - if ((!NILP (tem)) - && (!CONSP (tem) - || (!SYMBOLP (XCAR (tem)) && !CONSP (XCAR (tem))))) - signal_simple_error ("Invalid condition handler", tem); + if (NILP (handler)) + ; + else if (CONSP (handler)) + { + Lisp_Object conditions = XCAR (handler); + /* CONDITIONS must a condition name or a list of condition names */ + if (SYMBOLP (conditions)) + ; + else + { + Lisp_Object condition; + EXTERNAL_LIST_LOOP_2 (condition, conditions) + if (!SYMBOLP (condition)) + goto invalid_condition_handler; + } + } + else + { + invalid_condition_handler: + signal_simple_error ("Invalid condition handler", handler); + } } + CHECK_SYMBOL (var); + return condition_case_1 (handlers, - Feval, bodyform, - run_condition_case_handlers, - var); + Feval, bodyform, + run_condition_case_handlers, + var); } DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* Regain control when an error is signalled. Usage looks like (condition-case VAR BODYFORM HANDLERS...). -executes BODYFORM and returns its value if no error happens. +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. @@ -1755,9 +1758,10 @@ rather than when the handler was set, use `call-with-condition-handler'. (args)) { /* This function can GC */ - return condition_case_3 (XCAR (XCDR (args)), - XCAR (args), - XCDR (XCDR (args))); + Lisp_Object var = XCAR (args); + Lisp_Object bodyform = XCAR (XCDR (args)); + Lisp_Object handlers = XCDR (XCDR (args)); + return condition_case_3 (bodyform, var, handlers); } DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* @@ -1779,20 +1783,19 @@ and invokes the standard error-handler if none is found.) (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ { /* This function can GC */ - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; /* #### If there were a way to check that args[0] were a function which accepted one arg, that should be done here ... */ /* (handler-fun . handler-args) */ - tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); + tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); record_unwind_protect (condition_bind_unwind, tem); Vcondition_handlers = tem; /* Caller should have GC-protected args */ - tem = Ffuncall (nargs - 1, args + 1); - return unbind_to (speccount, tem); + return unbind_to (speccount, Ffuncall (nargs - 1, args + 1)); } static int @@ -1802,25 +1805,15 @@ condition_type_p (Lisp_Object type, Lisp_Object conditions) /* (condition-case c # (t c)) catches -all- signals * Use with caution! */ return 1; - else - { - if (SYMBOLP (type)) - { - return !NILP (Fmemq (type, conditions)); - } - else if (CONSP (type)) - { - while (CONSP (type)) - { - if (!NILP (Fmemq (Fcar (type), conditions))) - return 1; - type = XCDR (type); - } - return 0; - } - else - return 0; - } + + if (SYMBOLP (type)) + return !NILP (Fmemq (type, conditions)); + + for (; CONSP (type); type = XCDR (type)) + if (!NILP (Fmemq (XCAR (type), conditions))) + return 1; + + return 0; } static Lisp_Object @@ -1842,7 +1835,9 @@ return_from_signal (Lisp_Object value) extern int in_display; -/****************** the workhorse error-signaling function ******************/ +/************************************************************************/ +/* the workhorse error-signaling function */ +/************************************************************************/ /* #### This function has not been synched with FSF. It diverges significantly. */ @@ -2056,9 +2051,11 @@ signal_error (Lisp_Object sig, Lisp_Object data) static Lisp_Object call_with_suspended_errors_1 (Lisp_Object opaque_arg) { + Lisp_Object val; Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg); - return primitive_funcall ((lisp_fn_t) get_opaque_ptr (kludgy_args[0]), - XINT (kludgy_args[1]), kludgy_args + 2); + PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]), + kludgy_args + 2, XINT (kludgy_args[1])); + return val; } static Lisp_Object @@ -2134,9 +2131,13 @@ call_with_suspended_errors (lisp_fn_t fun, volatile Lisp_Object retval, enabled error-checking. */ if (ERRB_EQ (errb, ERROR_ME)) - return primitive_funcall (fun, nargs, args); + { + Lisp_Object val; + PRIMITIVE_FUNCALL (val, fun, args, nargs); + return val; + } - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); if (NILP (class) || NILP (Vcurrent_warning_class)) { /* If we're currently calling for no warnings, then make it so. @@ -2479,9 +2480,53 @@ signal_quit (void) } -/**********************************************************************/ -/* User commands */ -/**********************************************************************/ +/* Used in core lisp functions for efficiency */ +void +signal_void_function_error (Lisp_Object function) +{ + Fsignal (Qvoid_function, list1 (function)); +} + +static void +signal_invalid_function_error (Lisp_Object function) +{ + Fsignal (Qinvalid_function, list1 (function)); +} + +static void +signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) +{ + Fsignal (Qwrong_number_of_arguments, list2 (function, make_int (nargs))); +} + +/* Used in list traversal macros for efficiency. */ +void +signal_malformed_list_error (Lisp_Object list) +{ + Fsignal (Qmalformed_list, list1 (list)); +} + +void +signal_malformed_property_list_error (Lisp_Object list) +{ + Fsignal (Qmalformed_property_list, list1 (list)); +} + +void +signal_circular_list_error (Lisp_Object list) +{ + Fsignal (Qcircular_list, list1 (list)); +} + +void +signal_circular_property_list_error (Lisp_Object list) +{ + Fsignal (Qcircular_property_list, list1 (list)); +} + +/************************************************************************/ +/* User commands */ +/************************************************************************/ DEFUN ("commandp", Fcommandp, 1, 1, 0, /* Return t if FUNCTION makes provisions for interactive calling. @@ -2505,35 +2550,32 @@ Also, a symbol satisfies `commandp' if its function definition does so. { Lisp_Object fun = indirect_function (function, 0); - if (UNBOUNDP (fun)) - return Qnil; + if (COMPILED_FUNCTIONP (fun)) + return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; + + /* Lists may represent commands. */ + if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qlambda)) + return Fassq (Qinteractive, Fcdr (Fcdr (fun))); + if (EQ (funcar, Qautoload)) + return Fcar (Fcdr (Fcdr (Fcdr (fun)))); + else + return Qnil; + } /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ if (SUBRP (fun)) return XSUBR (fun)->prompt ? Qt : Qnil; - if (COMPILED_FUNCTIONP (fun)) - return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; - /* Strings and vectors are keyboard macros. */ if (VECTORP (fun) || STRINGP (fun)) return Qt; - /* Lists may represent commands. */ - if (!CONSP (fun)) - return Qnil; - { - Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - return Fsignal (Qinvalid_function, list1 (fun)); - if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (Fcdr (fun))); - if (EQ (funcar, Qautoload)) - return Fcar (Fcdr (Fcdr (Fcdr (fun)))); - else - return Qnil; - } + /* Everything else (including Qunbound) is not a command. */ + return Qnil; } DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* @@ -2570,14 +2612,11 @@ when reading the arguments. if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) { -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif backtrace.function = &Qcall_interactively; backtrace.args = &cmd; backtrace.nargs = 1; backtrace.evalargs = 0; - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.debug_on_exit = 0; PUSH_BACKTRACE (backtrace); @@ -2675,9 +2714,9 @@ and input is currently coming from the keyboard (not in keyboard macro). } -/**********************************************************************/ -/* Autoloading */ -/**********************************************************************/ +/************************************************************************/ +/* Autoloading */ +/************************************************************************/ DEFUN ("autoload", Fautoload, 2, 5, 0, /* Define FUNCTION to autoload from FILE. @@ -2700,10 +2739,11 @@ this does nothing and returns nil. CHECK_STRING (file); /* If function is defined and not as an autoload, don't override */ - if (!UNBOUNDP (XSYMBOL (function)->function) - && !(CONSP (XSYMBOL (function)->function) - && EQ (XCAR (XSYMBOL (function)->function), Qautoload))) - return Qnil; + { + Lisp_Object f = XSYMBOL (function)->function; + if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) + return Qnil; + } if (purify_flag) { @@ -2730,7 +2770,7 @@ un_autoload (Lisp_Object oldqueue) Vautoload_queue = oldqueue; while (CONSP (queue)) { - first = Fcar (queue); + first = XCAR (queue); second = Fcdr (first); first = Fcar (first); if (NILP (second)) @@ -2747,7 +2787,7 @@ do_autoload (Lisp_Object fundef, Lisp_Object funname) { /* This function can GC */ - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object fun = funname; struct gcpro gcpro1, gcpro2; @@ -2757,29 +2797,25 @@ do_autoload (Lisp_Object fundef, /* Value saved here is to be restored into Vautoload_queue */ record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; - call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, - Qnil); + call4 (Qload, Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil); { - Lisp_Object queue = Vautoload_queue; + Lisp_Object queue; /* Save the old autoloads, in case we ever do an unload. */ - queue = Vautoload_queue; - while (CONSP (queue)) - { - Lisp_Object first = Fcar (queue); - Lisp_Object second = Fcdr (first); - - first = Fcar (first); + for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) + { + Lisp_Object first = XCAR (queue); + Lisp_Object second = Fcdr (first); - /* Note: This test is subtle. The cdr of an autoload-queue entry - may be an atom if the autoload entry was generated by a defalias - or fset. */ - if (CONSP (second)) - Fput (first, Qautoload, (Fcdr (second))); + first = Fcar (first); - queue = Fcdr (queue); - } + /* Note: This test is subtle. The cdr of an autoload-queue entry + may be an atom if the autoload entry was generated by a defalias + or fset. */ + if (CONSP (second)) + Fput (first, Qautoload, (XCDR (second))); + } } /* Once loading finishes, don't undo it. */ @@ -2801,14 +2837,12 @@ do_autoload (Lisp_Object fundef, } -/**********************************************************************/ -/* eval, funcall, apply */ -/**********************************************************************/ +/************************************************************************/ +/* eval, funcall, apply */ +/************************************************************************/ static Lisp_Object funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]); -static Lisp_Object apply_lambda (Lisp_Object fun, - int nargs, Lisp_Object args); static int in_warnings; static Lisp_Object @@ -2818,51 +2852,6 @@ in_warnings_restore (Lisp_Object minimus) return Qnil; } -#define AV_0(av) -#define AV_1(av) av[0] -#define AV_2(av) AV_1(av), av[1] -#define AV_3(av) AV_2(av), av[2] -#define AV_4(av) AV_3(av), av[3] -#define AV_5(av) AV_4(av), av[4] -#define AV_6(av) AV_5(av), av[5] -#define AV_7(av) AV_6(av), av[6] -#define AV_8(av) AV_7(av), av[7] - -#define PRIMITIVE_FUNCALL(fn, av, ac) \ -(((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) - -/* If subr's take more than 8 arguments, more cases need to be added - to this switch. (But don't do it - if you really need a SUBR with - more than 8 arguments, use max_args == MANY. - See the DEFUN macro in lisp.h) */ -#define inline_funcall_fn(rv, fn, av, ac) do { \ - switch (ac) { \ - case 0: rv = PRIMITIVE_FUNCALL(fn, av, 0); break; \ - case 1: rv = PRIMITIVE_FUNCALL(fn, av, 1); break; \ - case 2: rv = PRIMITIVE_FUNCALL(fn, av, 2); break; \ - case 3: rv = PRIMITIVE_FUNCALL(fn, av, 3); break; \ - case 4: rv = PRIMITIVE_FUNCALL(fn, av, 4); break; \ - case 5: rv = PRIMITIVE_FUNCALL(fn, av, 5); break; \ - case 6: rv = PRIMITIVE_FUNCALL(fn, av, 6); break; \ - case 7: rv = PRIMITIVE_FUNCALL(fn, av, 7); break; \ - case 8: rv = PRIMITIVE_FUNCALL(fn, av, 8); break; \ - default: abort(); rv = Qnil; break; \ - } \ -} while (0) - -#define inline_funcall_subr(rv, subr, av) do { \ - void (*fn)() = (void (*)()) (subr_function(subr)); \ - inline_funcall_fn (rv, fn, av, subr->max_args); \ -} while (0) - -static Lisp_Object -primitive_funcall (lisp_fn_t fn, int nargs, Lisp_Object args[]) -{ - Lisp_Object rv; - inline_funcall_fn (rv, fn, args, nargs); - return rv; -} - DEFUN ("eval", Feval, 1, 1, 0, /* Evaluate FORM and return its value. */ @@ -2877,7 +2866,7 @@ Evaluate FORM and return its value. while (!in_warnings && !NILP (Vpending_warnings)) { struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object this_warning_cons, this_warning, class, level, messij; record_unwind_protect (in_warnings_restore, Qnil); @@ -2905,11 +2894,13 @@ Evaluate FORM and return its value. unbind_to (speccount, Qnil); } - if (SYMBOLP (form)) - return Fsymbol_value (form); - if (!CONSP (form)) - return form; + { + if (SYMBOLP (form)) + return Fsymbol_value (form); + else + return form; + } QUIT; if ((consing_since_gc > gc_cons_threshold) || always_gc) @@ -2928,34 +2919,13 @@ Evaluate FORM and return its value. error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - /* - * At this point we know that `form' is a Lisp_Cons so we can safely - * use XCAR and XCDR. - */ - original_fun = XCAR (form); + /* We guaranteed CONSP (form) above */ + original_fun = XCAR (form); original_args = XCDR (form); - /* - * Formerly we used a call to Flength here, but that is slow and - * wasteful due to type checking, stack push/pop and initialization. - * We know we're dealing with a cons, so open code it for speed. - * - * We call QUIT in the loop so that a circular arg list won't lock - * up the editor. - */ - for (nargs = 0, val = original_args ; CONSP (val) ; val = XCDR (val)) - { - nargs++; - QUIT; - } - if (! NILP (val)) - signal_simple_error ("Argument list must be nil-terminated", - original_args); + GET_EXTERNAL_LIST_LENGTH (original_args, nargs); -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.function = &original_fun; /* This also protects them from gc */ backtrace.args = &original_args; backtrace.nargs = UNEVALLED; @@ -2970,125 +2940,173 @@ Evaluate FORM and return its value. profile_increase_call_count (original_fun); /* At this point, only original_fun and original_args - have values that will be used below */ + have values that will be used below. */ retry: fun = indirect_function (original_fun, 1); if (SUBRP (fun)) { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; - Lisp_Object argvals[SUBR_MAX_ARGS]; - Lisp_Object args_left; - REGISTER int i; - args_left = original_args; + if (nargs < subr->min_args) + goto wrong_number_of_arguments; - if (nargs < subr->min_args - || (max_args >= 0 && max_args < nargs)) - { - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); - } - - if (max_args == UNEVALLED) + if (max_args == UNEVALLED) /* Optimize for the common case */ { backtrace.evalargs = 0; - val = ((Lisp_Object (*) (Lisp_Object)) (subr_function (subr))) (args_left); + val = (((Lisp_Object (*) (Lisp_Object)) (subr_function (subr))) + (original_args)); } + else if (nargs <= max_args) + { + struct gcpro gcpro1; + Lisp_Object args[SUBR_MAX_ARGS]; + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + REGISTER Lisp_Object arg; + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + /* &optional args default to nil. */ + while (p - args < max_args) + *p++ = Qnil; + + backtrace.args = args; + backtrace.nargs = nargs; + FUNCALL_SUBR (val, subr, args, max_args); + + UNGCPRO; + } else if (max_args == MANY) { /* Pass a vector of evaluated arguments */ - Lisp_Object *vals; - REGISTER int argnum; - struct gcpro gcpro1, gcpro2, gcpro3; - - vals = alloca_array (Lisp_Object, nargs); - - GCPRO3 (args_left, fun, vals[0]); - gcpro3.nvars = 0; - - argnum = 0; - while (CONSP (args_left)) - { - vals[argnum++] = Feval (XCAR (args_left)); - args_left = XCDR (args_left); - gcpro3.nvars = argnum; - } - - backtrace.args = vals; + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + REGISTER Lisp_Object arg; + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + backtrace.args = args; backtrace.nargs = nargs; - val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) - (nargs, vals); - - /* Have to duplicate this code because if the - * debugger is called it must be in a scope in - * which the `alloca'-ed data in vals is still valid. - * (And GC-protected.) - */ - lisp_eval_depth--; - if (backtrace.debug_on_exit) - val = do_debug_on_exit (val); - POP_BACKTRACE (backtrace); + val = (((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) + (nargs, args)); + UNGCPRO; - return val; } - else - { - struct gcpro gcpro1, gcpro2, gcpro3; + { + wrong_number_of_arguments: + signal_wrong_number_of_arguments_error (fun, nargs); + } + } + else if (COMPILED_FUNCTIONP (fun)) + { + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; - GCPRO3 (args_left, fun, fun); - gcpro3.var = argvals; - gcpro3.nvars = 0; + GCPRO1 (args[0]); + gcpro1.nvars = 0; - for (i = 0; i < nargs; args_left = XCDR (args_left)) - { - argvals[i] = Feval (XCAR (args_left)); - gcpro3.nvars = ++i; - } + { + REGISTER Lisp_Object arg; + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } - UNGCPRO; + backtrace.args = args; + backtrace.nargs = nargs; + backtrace.evalargs = 0; - /* i == nargs at this point */ - for (; i < max_args; i++) - argvals[i] = Qnil; + val = funcall_compiled_function (fun, nargs, args); - backtrace.args = argvals; - backtrace.nargs = nargs; + /* Do the debug-on-exit now, while args is still GCPROed. */ + if (backtrace.debug_on_exit) + val = do_debug_on_exit (val); + /* Don't do it again when we return to eval. */ + backtrace.debug_on_exit = 0; - /* val = funcall_subr (subr, argvals); */ - inline_funcall_subr (val, subr, argvals); - } + UNGCPRO; } - else if (COMPILED_FUNCTIONP (fun)) - val = apply_lambda (fun, nargs, original_args); - else + else if (CONSP (fun)) { - Lisp_Object funcar; + Lisp_Object funcar = XCAR (fun); - if (!CONSP (fun)) - goto invalid_function; - funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qautoload)) { do_autoload (fun, original_fun); goto retry; } - if (EQ (funcar, Qmacro)) - val = Feval (apply1 (XCDR (fun), original_args)); + else if (EQ (funcar, Qmacro)) + { + val = Feval (apply1 (XCDR (fun), original_args)); + } else if (EQ (funcar, Qlambda)) - val = apply_lambda (fun, nargs, original_args); + { + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + REGISTER Lisp_Object arg; + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + UNGCPRO; + + backtrace.args = args; /* this also GCPROs `args' */ + backtrace.nargs = nargs; + backtrace.evalargs = 0; + + val = funcall_lambda (fun, nargs, args); + + /* Do the debug-on-exit now, while args is still GCPROed. */ + if (backtrace.debug_on_exit) + val = do_debug_on_exit (val); + /* Don't do it again when we return to eval. */ + backtrace.debug_on_exit = 0; + } else { - invalid_function: - return Fsignal (Qinvalid_function, list1 (fun)); + goto invalid_function; } } + else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */ + { + invalid_function: + signal_invalid_function_error (fun); + } lisp_eval_depth--; if (backtrace.debug_on_exit) @@ -3098,15 +3116,18 @@ Evaluate FORM and return its value. } -Lisp_Object -funcall_recording_as (Lisp_Object recorded_as, int nargs, - Lisp_Object *args) +DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* +Call first argument as a function, passing the remaining arguments to it. +Thus, (funcall 'cons 'x 'y) returns (x . y). +*/ + (int nargs, Lisp_Object *args)) { /* This function can GC */ Lisp_Object fun; Lisp_Object val; struct backtrace backtrace; - REGISTER int i; + int fun_nargs = nargs - 1; + Lisp_Object *fun_args = args + 1; QUIT; if ((consing_since_gc > gc_cons_threshold) || always_gc) @@ -3121,16 +3142,10 @@ funcall_recording_as (Lisp_Object recorded_as, int nargs, error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - /* Count number of arguments to function */ - nargs = nargs - 1; - -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.function = &args[0]; - backtrace.args = &args[1]; - backtrace.nargs = nargs; + backtrace.args = fun_args; + backtrace.nargs = fun_nargs; backtrace.evalargs = 0; backtrace.debug_on_exit = 0; PUSH_BACKTRACE (backtrace); @@ -3142,86 +3157,97 @@ funcall_recording_as (Lisp_Object recorded_as, int nargs, fun = args[0]; -#ifdef EMACS_BTL - { - extern int emacs_btl_elisp_only_p; - extern int btl_symbol_id_number (); - if (emacs_btl_elisp_only_p) - backtrace.id_number = btl_symbol_id_number (fun); - } -#endif - /* It might be useful to place this *after* all the checks. */ if (profiling_active) profile_increase_call_count (fun); + /* We could call indirect_function directly, but profiling shows + this is worth optimizing by partially unrolling the loop. */ if (SYMBOLP (fun)) - fun = indirect_function (fun, 1); + { + fun = XSYMBOL (fun)->function; + if (SYMBOLP (fun)) + { + fun = XSYMBOL (fun)->function; + if (SYMBOLP (fun)) + fun = indirect_function (fun, 1); + } + } if (SUBRP (fun)) { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; + Lisp_Object spacious_args[SUBR_MAX_ARGS]; - if (max_args == UNEVALLED) - return Fsignal (Qinvalid_function, list1 (fun)); + if (fun_nargs < subr->min_args) + goto wrong_number_of_arguments; - if (nargs < subr->min_args - || (max_args >= 0 && max_args < nargs)) + if (fun_nargs == max_args) /* Optimize for the common case */ { - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); + funcall_subr: + FUNCALL_SUBR (val, subr, fun_args, max_args); } + else if (fun_nargs < max_args) + { + Lisp_Object *p = spacious_args; - if (max_args == MANY) + /* Default optionals to nil */ + while (fun_nargs--) + *p++ = *fun_args++; + while (p - spacious_args < max_args) + *p++ = Qnil; + + fun_args = spacious_args; + goto funcall_subr; + } + else if (max_args == MANY) { val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) - (nargs, args + 1); + (fun_nargs, fun_args); } - - else if (max_args > nargs) + else if (max_args == UNEVALLED) /* Can't funcall a special form */ { - Lisp_Object argvals[SUBR_MAX_ARGS]; - - /* Default optionals to nil */ - for (i = 0; i < nargs; i++) - argvals[i] = args[i + 1]; - for (i = nargs; i < max_args; i++) - argvals[i] = Qnil; - - /* val = funcall_subr (subr, argvals); */ - inline_funcall_subr (val, subr, argvals); + goto invalid_function; } else - /* val = funcall_subr (subr, args + 1); */ - inline_funcall_subr (val, subr, (&args[1])); + { + wrong_number_of_arguments: + signal_wrong_number_of_arguments_error (fun, fun_nargs); + } } else if (COMPILED_FUNCTIONP (fun)) - val = funcall_lambda (fun, nargs, args + 1); - else if (!CONSP (fun)) { - invalid_function: - return Fsignal (Qinvalid_function, list1 (fun)); + val = funcall_compiled_function (fun, fun_nargs, fun_args); } - else + else if (CONSP (fun)) { - /* `fun' is a Lisp_Cons so XCAR is safe */ Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qlambda)) - val = funcall_lambda (fun, nargs, args + 1); + { + val = funcall_lambda (fun, fun_nargs, fun_args); + } else if (EQ (funcar, Qautoload)) { do_autoload (fun, args[0]); goto retry; } - else + else /* Can't funcall a macro */ { - goto invalid_function; + goto invalid_function; } } + else if (UNBOUNDP (fun)) + { + signal_void_function_error (args[0]); + } + else + { + invalid_function: + signal_invalid_function_error (fun); + } + lisp_eval_depth--; if (backtrace.debug_on_exit) val = do_debug_on_exit (val); @@ -3229,25 +3255,30 @@ funcall_recording_as (Lisp_Object recorded_as, int nargs, return val; } -DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* -Call first argument as a function, passing remaining arguments to it. -Thus, (funcall 'cons 'x 'y) returns (x . y). +DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* +Return t if OBJECT can be called as a function, else nil. +A function is an object that can be applied to arguments, +using for example `funcall' or `apply'. */ - (int nargs, Lisp_Object *args)) + (object)) { - return funcall_recording_as (args[0], nargs, args); + if (SYMBOLP (object)) + object = indirect_function (object, 0); + + return + (SUBRP (object) || + COMPILED_FUNCTIONP (object) || + (CONSP (object) && + (EQ (XCAR (object), Qlambda) || + EQ (XCAR (object), Qautoload)))) + ? Qt : Qnil; } -DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* -Return the number of arguments a function may be called with. The -function may be any form that can be passed to `funcall', any special -form, or any macro. -*/ - (function)) +static Lisp_Object +function_argcount (Lisp_Object function, int function_min_args_p) { Lisp_Object orig_function = function; Lisp_Object arglist; - int argcount; retry: @@ -3255,148 +3286,108 @@ form, or any macro. function = indirect_function (function, 1); if (SUBRP (function)) - return Fsubr_min_args (function); - else if (!COMPILED_FUNCTIONP (function) && !CONSP (function)) { - invalid_function: - return Fsignal (Qinvalid_function, list1 (function)); + return function_min_args_p ? + Fsubr_min_args (function): + Fsubr_max_args (function); + } + else if (COMPILED_FUNCTIONP (function)) + { + arglist = compiled_function_arglist (XCOMPILED_FUNCTION (function)); } - - if (CONSP (function)) + else if (CONSP (function)) { Lisp_Object funcar = XCAR (function); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qmacro)) { function = XCDR (function); goto retry; } - if (EQ (funcar, Qautoload)) + else if (EQ (funcar, Qautoload)) { do_autoload (function, orig_function); goto retry; } - if (EQ (funcar, Qlambda)) - arglist = Fcar (XCDR (function)); + else if (EQ (funcar, Qlambda)) + { + arglist = Fcar (XCDR (function)); + } else - goto invalid_function; + { + goto invalid_function; + } } else - arglist = XCOMPILED_FUNCTION (function)->arglist; - - argcount = 0; - while (!NILP (arglist)) { - QUIT; - if (EQ (Fcar (arglist), Qand_optional) - || EQ (Fcar (arglist), Qand_rest)) - break; - argcount++; - arglist = Fcdr (arglist); + invalid_function: + return Fsignal (Qinvalid_function, list1 (function)); } - return make_int (argcount); + { + int argcount = 0; + Lisp_Object arg; + + EXTERNAL_LIST_LOOP_2 (arg, arglist) + { + if (EQ (arg, Qand_optional)) + { + if (function_min_args_p) + break; + } + else if (EQ (arg, Qand_rest)) + { + if (function_min_args_p) + break; + else + return Qnil; + } + else + { + argcount++; + } + } + + return make_int (argcount); + } } -DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* -Return the number of arguments a function may be called with. If the -function takes an arbitrary number of arguments or is a built-in -special form, nil is returned. The function may be any form that can -be passed to `funcall', any special form, or any macro. +DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* +Return the number of arguments a function may be called with. +The function may be any form that can be passed to `funcall', +any special form, or any macro. */ (function)) { - Lisp_Object orig_function = function; - Lisp_Object arglist; - int argcount; - - retry: - - if (SYMBOLP (function)) - function = indirect_function (function, 1); - - if (SUBRP (function)) - return Fsubr_max_args (function); - else if (!COMPILED_FUNCTIONP (function) && !CONSP (function)) - { - invalid_function: - return Fsignal (Qinvalid_function, list1 (function)); - } - - if (CONSP (function)) - { - Lisp_Object funcar = XCAR (function); - - if (!SYMBOLP (funcar)) - goto invalid_function; - if (EQ (funcar, Qmacro)) - { - function = XCDR (function); - goto retry; - } - if (EQ (funcar, Qautoload)) - { - do_autoload (function, orig_function); - goto retry; - } - if (EQ (funcar, Qlambda)) - arglist = Fcar (XCDR (function)); - else - goto invalid_function; - } - else - arglist = XCOMPILED_FUNCTION (function)->arglist; - - argcount = 0; - while (!NILP (arglist)) - { - QUIT; - if (EQ (Fcar (arglist), Qand_optional)) - { - arglist = Fcdr (arglist); - continue; - } - if (EQ (Fcar (arglist), Qand_rest)) - return Qnil; - argcount++; - arglist = Fcdr (arglist); - } + return function_argcount (function, 1); +} - return make_int (argcount); +DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* +Return the number of arguments a function may be called with. +The function may be any form that can be passed to `funcall', +any special form, or any macro. +If the function takes an arbitrary number of arguments or is +a built-in special form, nil is returned. +*/ + (function)) +{ + return function_argcount (function, 0); } DEFUN ("apply", Fapply, 2, MANY, 0, /* -Call FUNCTION with our remaining args, using our last arg as list of args. +Call FUNCTION with the remaining args, using the last arg as a list of args. Thus, (apply '+ 1 2 '(3 4)) returns 10. */ (int nargs, Lisp_Object *args)) { /* This function can GC */ Lisp_Object fun = args[0]; - Lisp_Object spread_arg = args [nargs - 1], p; + Lisp_Object spread_arg = args [nargs - 1]; int numargs; int funcall_nargs; - CHECK_LIST (spread_arg); - - /* - * Formerly we used a call to Flength here, but that is slow and - * wasteful due to type checking, stack push/pop and initialization. - * We know we're dealing with a cons, so open code it for speed. - * - * We call QUIT in the loop so that a circular arg list won't lock - * up the editor. - */ - for (numargs = 0, p = spread_arg ; CONSP (p) ; p = XCDR (p)) - { - numargs++; - QUIT; - } - if (! NILP (p)) - signal_simple_error ("Argument list must be nil-terminated", spread_arg); + GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); if (numargs == 0) /* (apply foo 0 1 '()) */ @@ -3415,14 +3406,10 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. if (SYMBOLP (fun)) fun = indirect_function (fun, 0); - if (UNBOUNDP (fun)) - { - /* Let funcall get the error */ - fun = args[0]; - } - else if (SUBRP (fun)) + + if (SUBRP (fun)) { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; if (numargs < subr->min_args @@ -3437,6 +3424,12 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. funcall_nargs += (max_args - numargs); } } + else if (UNBOUNDP (fun)) + { + /* Let funcall get the error */ + fun = args[0]; + } + { REGISTER int i; Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); @@ -3465,145 +3458,66 @@ Thus, (apply '+ 1 2 '(3 4)) returns 10. } -/* FSFmacs has an extra arg EVAL_FLAG. If false, some of - the statements below are not done. But it's always true - in all the calls to apply_lambda(). */ +/* Apply lambda list FUN to the NARGS evaluated arguments in ARGS and + return the result of evaluation. */ static Lisp_Object -apply_lambda (Lisp_Object fun, int numargs, Lisp_Object unevalled_args) +funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]) { /* This function can GC */ - struct gcpro gcpro1, gcpro2, gcpro3; - REGISTER int i; - REGISTER Lisp_Object tem; - REGISTER Lisp_Object *arg_vector = alloca_array (Lisp_Object, numargs); + Lisp_Object symbol, arglist, body, tail; + int speccount = specpdl_depth(); + REGISTER int i = 0; - GCPRO3 (*arg_vector, unevalled_args, fun); - gcpro1.nvars = 0; + tail = XCDR (fun); - for (i = 0; i < numargs;) - { - /* - * unevalled_args is always a normal list, or Feval would have - * rejected it, so use XCAR and XCDR. - */ - tem = XCAR (unevalled_args), unevalled_args = XCDR (unevalled_args); - tem = Feval (tem); - arg_vector[i++] = tem; - gcpro1.nvars = i; - } - - UNGCPRO; + if (!CONSP (tail)) + goto invalid_function; - backtrace_list->args = arg_vector; - backtrace_list->nargs = i; - backtrace_list->evalargs = 0; - tem = funcall_lambda (fun, numargs, arg_vector); - - /* Do the debug-on-exit now, while arg_vector still exists. */ - if (backtrace_list->debug_on_exit) - tem = do_debug_on_exit (tem); - /* Don't do it again when we return to eval. */ - backtrace_list->debug_on_exit = 0; - return tem; -} - -DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* -If byte-compiled OBJECT is lazy-loaded, fetch it now. -*/ - (object)) -{ - if (COMPILED_FUNCTIONP (object) - && CONSP (XCOMPILED_FUNCTION (object)->bytecodes)) - { - Lisp_Object tem = - read_doc_string (XCOMPILED_FUNCTION (object)->bytecodes); - if (!CONSP (tem)) - signal_simple_error ("invalid lazy-loaded byte code", tem); - /* v18 or v19 bytecode file. Need to Ebolify. */ - if (XCOMPILED_FUNCTION (object)->flags.ebolified - && VECTORP (XCDR (tem))) - ebolify_bytecode_constants (XCDR (tem)); - /* VERY IMPORTANT to purecopy here!!!!! - See load_force_doc_string_unwind. */ - XCOMPILED_FUNCTION (object)->bytecodes = Fpurecopy (XCAR (tem)); - XCOMPILED_FUNCTION (object)->constants = Fpurecopy (XCDR (tem)); - } - return object; -} + arglist = XCAR (tail); + body = XCDR (tail); -/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR - and return the result of evaluation. - FUN must be either a lambda-expression or a compiled-code object. */ + { + int optional = 0, rest = 0; -static Lisp_Object -funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object arg_vector[]) -{ - /* This function can GC */ - Lisp_Object val, tem; - REGISTER Lisp_Object syms_left; - REGISTER Lisp_Object next; - int speccount = specpdl_depth_counter; - REGISTER int i; - int optional = 0, rest = 0; + EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail) + { + if (!SYMBOLP (symbol)) + goto invalid_function; + if (EQ (symbol, Qand_rest)) + rest = 1; + else if (EQ (symbol, Qand_optional)) + optional = 1; + else if (rest) + { + specbind (symbol, Flist (nargs - i, &args[i])); + i = nargs; + } + else if (i < nargs) + specbind (symbol, args[i++]); + else if (!optional) + goto wrong_number_of_arguments; + else + specbind (symbol, Qnil); + } + } - if (CONSP (fun)) - syms_left = Fcar (XCDR (fun)); - else if (COMPILED_FUNCTIONP (fun)) - syms_left = XCOMPILED_FUNCTION (fun)->arglist; - else abort (); + if (i < nargs) + goto wrong_number_of_arguments; - i = 0; - for (; CONSP (syms_left); syms_left = XCDR (syms_left)) - { - QUIT; - next = XCAR (syms_left); - if (!SYMBOLP (next)) - signal_error (Qinvalid_function, list1 (fun)); - if (EQ (next, Qand_rest)) - rest = 1; - else if (EQ (next, Qand_optional)) - optional = 1; - else if (rest) - { - specbind (next, Flist (nargs - i, &arg_vector[i])); - i = nargs; - } - else if (i < nargs) - { - tem = arg_vector[i++]; - specbind (next, tem); - } - else if (!optional) - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); - else - specbind (next, Qnil); - } + return unbind_to (speccount, Fprogn (body)); - if (i < nargs) - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); + wrong_number_of_arguments: + return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); - if (CONSP (fun)) - val = Fprogn (Fcdr (XCDR (fun))); - else - { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (b->bytecodes)) - Ffetch_bytecode (fun); - val = Fbyte_code (b->bytecodes, - b->constants, - make_int (b->maxdepth)); - } - return unbind_to (speccount, val); + invalid_function: + return Fsignal (Qinvalid_function, list1 (fun)); } + -/**********************************************************************/ -/* Run hook variables in various ways. */ -/**********************************************************************/ +/************************************************************************/ +/* Run hook variables in various ways. */ +/************************************************************************/ DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* Run each hook in HOOKS. Major mode functions use this. @@ -3691,7 +3605,6 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, enum run_hooks_condition cond) { Lisp_Object sym, val, ret; - struct gcpro gcpro1, gcpro2; if (!initialized || preparing_for_armageddon) /* We need to bail out of here pronto. */ @@ -3714,6 +3627,7 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args, } else { + struct gcpro gcpro1, gcpro2; GCPRO2 (sym, val); for (; @@ -3784,11 +3698,10 @@ run_hook_with_args (int nargs, Lisp_Object *args, Lisp_Object run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) { - Lisp_Object sym; + Lisp_Object sym = args[0]; Lisp_Object val; struct gcpro gcpro1, gcpro2; - sym = args[0]; GCPRO2 (sym, val); for (val = funlist; CONSP (val); val = XCDR (val)) @@ -3874,9 +3787,9 @@ run_hook (Lisp_Object hook) } -/**********************************************************************/ -/* Front-ends to eval, funcall, apply */ -/**********************************************************************/ +/************************************************************************/ +/* Front-ends to eval, funcall, apply */ +/************************************************************************/ /* Apply fn to arg */ Lisp_Object @@ -4066,7 +3979,7 @@ call0_in_buffer (struct buffer *buf, Lisp_Object fn) else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call0 (fn); @@ -4084,7 +3997,7 @@ call1_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call1 (fn, arg0); @@ -4102,7 +4015,7 @@ call2_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call2 (fn, arg0, arg1); @@ -4120,7 +4033,7 @@ call3_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call3 (fn, arg0, arg1, arg2); @@ -4139,7 +4052,7 @@ call4_in_buffer (struct buffer *buf, Lisp_Object fn, else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call4 (fn, arg0, arg1, arg2, arg3); @@ -4156,7 +4069,7 @@ eval_in_buffer (struct buffer *buf, Lisp_Object form) else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = Feval (form); @@ -4166,7 +4079,9 @@ eval_in_buffer (struct buffer *buf, Lisp_Object form) } -/***** Error-catching front-ends to eval, funcall, apply */ +/************************************************************************/ +/* Error-catching front-ends to eval, funcall, apply */ +/************************************************************************/ /* Call function fn on no arguments, with condition handler */ Lisp_Object @@ -4279,7 +4194,7 @@ Lisp_Object eval_in_buffer_trapping_errors (CONST char *warning_string, struct buffer *buf, Lisp_Object form) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object buffer; Lisp_Object cons; @@ -4329,7 +4244,7 @@ run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol) if (NILP (tem) || UNBOUNDP (tem)) return Qnil; - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (Qinhibit_quit, Qt); opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); @@ -4353,7 +4268,7 @@ safe_run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol, int allow_quit) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; struct gcpro gcpro1; @@ -4410,7 +4325,7 @@ call0_trapping_errors (CONST char *warning_string, Lisp_Object function) } GCPRO2 (opaque, function); - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (Qinhibit_quit, Qt); /* gc_currently_forbidden = 1; Currently no reason to do this; */ @@ -4445,7 +4360,7 @@ Lisp_Object call1_trapping_errors (CONST char *warning_string, Lisp_Object function, Lisp_Object object) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; Lisp_Object opaque = Qnil; @@ -4482,7 +4397,7 @@ Lisp_Object call2_trapping_errors (CONST char *warning_string, Lisp_Object function, Lisp_Object object1, Lisp_Object object2) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; Lisp_Object opaque = Qnil; @@ -4515,33 +4430,40 @@ call2_trapping_errors (CONST char *warning_string, Lisp_Object function, } -/**********************************************************************/ -/* The special binding stack */ -/**********************************************************************/ +/************************************************************************/ +/* The special binding stack */ +/* Most C code should simply use specbind() and unbind_to(). */ +/* When performance is critical, use the macros in backtrace.h. */ +/************************************************************************/ #define min_max_specpdl_size 400 -static void -grow_specpdl (void) +void +grow_specpdl (size_t reserved) { - if (specpdl_size >= max_specpdl_size) + size_t size_needed = specpdl_depth() + reserved; + if (size_needed >= max_specpdl_size) { if (max_specpdl_size < min_max_specpdl_size) max_specpdl_size = min_max_specpdl_size; - if (specpdl_size >= max_specpdl_size) + if (size_needed >= max_specpdl_size) { - if (!NILP (Vdebug_on_error) || !NILP (Vdebug_on_signal)) + if (!NILP (Vdebug_on_error) || + !NILP (Vdebug_on_signal)) /* Leave room for some specpdl in the debugger. */ - max_specpdl_size = specpdl_size + 100; + max_specpdl_size = size_needed + 100; continuable_error ("Variable binding depth exceeds max-specpdl-size"); } } - specpdl_size *= 2; - if (specpdl_size > max_specpdl_size) - specpdl_size = max_specpdl_size; + while (specpdl_size < size_needed) + { + specpdl_size *= 2; + if (specpdl_size > max_specpdl_size) + specpdl_size = max_specpdl_size; + } XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); - specpdl_ptr = specpdl + specpdl_depth_counter; + specpdl_ptr = specpdl + specpdl_depth(); } @@ -4620,14 +4542,15 @@ specbind_unwind_wasnt_local (Lisp_Object buffer) void specbind (Lisp_Object symbol, Lisp_Object value) { - int buffer_local; - - CHECK_SYMBOL (symbol); + SPECBIND (symbol, value); +} - if (specpdl_depth_counter >= specpdl_size) - grow_specpdl (); +void +specbind_magic (Lisp_Object symbol, Lisp_Object value) +{ + int buffer_local = + symbol_value_buffer_local_info (symbol, current_buffer); - buffer_local = symbol_value_buffer_local_info (symbol, current_buffer); if (buffer_local == 0) { specpdl_ptr->old_value = find_symbol_value (symbol); @@ -4658,8 +4581,7 @@ void record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), Lisp_Object arg) { - if (specpdl_depth_counter >= specpdl_size) - grow_specpdl (); + SPECPDL_RESERVE (1); specpdl_ptr->func = function; specpdl_ptr->symbol = Qnil; specpdl_ptr->old_value = arg; @@ -4669,31 +4591,50 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), extern int check_sigio (void); +/* Unwind the stack till specpdl_depth() == COUNT. + VALUE is not used, except that, purely as a convenience to the + caller, it is protected from garbage-protection. */ Lisp_Object unbind_to (int count, Lisp_Object value) { - int quitf; - struct gcpro gcpro1; + UNBIND_TO_GCPRO (count, value); + return value; +} - GCPRO1 (value); +/* Don't call this directly. + Only for use by UNBIND_TO* macros in backtrace.h */ +void +unbind_to_hairy (int count) +{ + int quitf; check_quit (); /* make Vquit_flag accurate */ quitf = !NILP (Vquit_flag); Vquit_flag = Qnil; + ++specpdl_ptr; + ++specpdl_depth_counter; + while (specpdl_depth_counter != count) { - Lisp_Object ovalue; --specpdl_ptr; --specpdl_depth_counter; - ovalue = specpdl_ptr->old_value; if (specpdl_ptr->func != 0) /* An unwind-protect */ - (*specpdl_ptr->func) (ovalue); + (*specpdl_ptr->func) (specpdl_ptr->old_value); else - Fset (specpdl_ptr->symbol, ovalue); + { + /* We checked symbol for validity when we specbound it, + so only need to call Fset if symbol has magic value. */ + struct Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); + if (!SYMBOL_VALUE_MAGIC_P (sym->value)) + sym->value = specpdl_ptr->old_value; + else + Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); + } +#if 0 /* martin */ #ifndef EXCEEDINGLY_QUESTIONABLE_CODE /* There should never be anything here for us to remove. If so, it indicates a logic error in Emacs. Catches @@ -4711,21 +4652,12 @@ unbind_to (int count, Lisp_Object value) /* Don't mess with gcprolist, backtrace_list here */ } #endif +#endif } if (quitf) Vquit_flag = Qt; - - UNGCPRO; - - return value; } - -int -specpdl_depth (void) -{ - return specpdl_depth_counter; -} /* Get the value of symbol's global binding, even if that binding is @@ -4767,9 +4699,9 @@ top_level_set (Lisp_Object symbol, Lisp_Object newval) #endif /* 0 */ -/**********************************************************************/ -/* Backtraces */ -/**********************************************************************/ +/************************************************************************/ +/* Backtraces */ +/************************************************************************/ DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. @@ -4832,7 +4764,7 @@ function calls. /* This function can GC */ struct backtrace *backlist = backtrace_list; struct catchtag *catches = catchlist; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); int old_nl = print_escape_newlines; int old_pr = print_readably; @@ -4989,9 +4921,9 @@ If N is more than the number of frames, the value is nil. } -/**********************************************************************/ -/* Warnings */ -/**********************************************************************/ +/************************************************************************/ +/* Warnings */ +/************************************************************************/ void warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level, @@ -5011,7 +4943,7 @@ warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level, to make sure that Feval() isn't called, since it might not be safe. An alternative approach is to just pass some non-string type of - Lisp Object to warn_when_safe_lispobj(); `prin1-to-string' will + Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will automatically be called when it is safe to do so. */ void @@ -5031,9 +4963,9 @@ warn_when_safe (Lisp_Object class, Lisp_Object level, CONST char *fmt, ...) -/**********************************************************************/ -/* Initialization */ -/**********************************************************************/ +/************************************************************************/ +/* Initialization */ +/************************************************************************/ void syms_of_eval (void) @@ -5058,10 +4990,13 @@ syms_of_eval (void) defsymbol (&Qvalues, "values"); defsymbol (&Qdisplay_warning, "display-warning"); defsymbol (&Qrun_hooks, "run-hooks"); + defsymbol (&Qif, "if"); DEFSUBR (For); DEFSUBR (Fand); DEFSUBR (Fif); + DEFSUBR_MACRO (Fwhen); + DEFSUBR_MACRO (Funless); DEFSUBR (Fcond); DEFSUBR (Fprogn); DEFSUBR (Fprog1); @@ -5091,13 +5026,13 @@ syms_of_eval (void) DEFSUBR (Feval); DEFSUBR (Fapply); DEFSUBR (Ffuncall); + DEFSUBR (Ffunctionp); DEFSUBR (Ffunction_min_args); DEFSUBR (Ffunction_max_args); DEFSUBR (Frun_hooks); DEFSUBR (Frun_hook_with_args); DEFSUBR (Frun_hook_with_args_until_success); DEFSUBR (Frun_hook_with_args_until_failure); - DEFSUBR (Ffetch_bytecode); DEFSUBR (Fbacktrace_debug); DEFSUBR (Fbacktrace); DEFSUBR (Fbacktrace_frame); @@ -5249,7 +5184,9 @@ If due to `eval' entry, one arg, t. /* XEmacs change: increase these values. */ max_specpdl_size = 3000; max_lisp_eval_depth = 500; +#if 0 /* no longer used */ throw_level = 0; +#endif reinit_eval (); } diff --git a/src/event-Xt.c b/src/event-Xt.c index 5052edd..ace3470 100644 --- a/src/event-Xt.c +++ b/src/event-Xt.c @@ -31,7 +31,6 @@ Boston, MA 02111-1307, USA. */ #include "blocktype.h" #include "buffer.h" -#include "commands.h" #include "console.h" #include "console-tty.h" #include "events.h" @@ -181,7 +180,7 @@ x_reset_key_mapping (struct device *d) Display *display = DEVICE_X_DISPLAY (d); struct x_device *xd = DEVICE_X_DATA (d); KeySym *keysym, *keysym_end; - Lisp_Object hashtable; + Lisp_Object hash_table; int key_code_count, keysyms_per_code; if (xd->x_keysym_map) @@ -194,12 +193,12 @@ x_reset_key_mapping (struct device *d) XGetKeyboardMapping (display, xd->x_keysym_map_min_code, key_code_count, &xd->x_keysym_map_keysyms_per_code); - hashtable = xd->x_keysym_map_hashtable; - if (HASHTABLEP (hashtable)) - Fclrhash (hashtable); + hash_table = xd->x_keysym_map_hash_table; + if (HASH_TABLEP (hash_table)) + Fclrhash (hash_table); else - xd->x_keysym_map_hashtable = hashtable = - make_lisp_hashtable (128, HASHTABLE_NONWEAK, HASHTABLE_EQUAL); + xd->x_keysym_map_hash_table = hash_table = + make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); for (keysym = xd->x_keysym_map, keysyms_per_code = xd->x_keysym_map_keysyms_per_code, @@ -217,8 +216,8 @@ x_reset_key_mapping (struct device *d) Lisp_Object sym = x_keysym_to_emacs_keysym (keysym[0], 0); if (name) { - Fputhash (build_string (name), Qsans_modifiers, hashtable); - Fputhash (sym, Qsans_modifiers, hashtable); + Fputhash (build_string (name), Qsans_modifiers, hash_table); + Fputhash (sym, Qsans_modifiers, hash_table); } } @@ -229,10 +228,10 @@ x_reset_key_mapping (struct device *d) { char *name = XKeysymToString (keysym[j]); Lisp_Object sym = x_keysym_to_emacs_keysym (keysym[j], 0); - if (name && NILP (Fgethash (sym, hashtable, Qnil))) + if (name && NILP (Fgethash (sym, hash_table, Qnil))) { - Fputhash (build_string (name), Qt, hashtable); - Fputhash (sym, Qt, hashtable); + Fputhash (build_string (name), Qt, hash_table); + Fputhash (sym, Qt, hash_table); } } } @@ -450,7 +449,7 @@ void x_init_modifier_mapping (struct device *d) { struct x_device *xd = DEVICE_X_DATA (d); - xd->x_keysym_map_hashtable = Qnil; + xd->x_keysym_map_hash_table = Qnil; xd->x_keysym_map = NULL; xd->x_modifier_keymap = NULL; x_reset_modifier_mapping (d); @@ -772,7 +771,7 @@ x_to_emacs_keysym (XKeyPressedEvent *event, int simple_p) /* simple_p means don't try too hard (ASCII only) */ { KeySym keysym = 0; - + #ifdef HAVE_XIM int len; char buffer[64]; @@ -1136,7 +1135,7 @@ x_event_to_emacs_event (XEvent *x_event, struct Lisp_Event *emacs_event) emacs_event->timestamp = DEVICE_X_LAST_SERVER_TIMESTAMP (d); state=DndDragButtons(x_event); - + if (state & ShiftMask) modifiers |= MOD_SHIFT; if (state & ControlMask) modifiers |= MOD_CONTROL; if (state & xd->MetaMask) modifiers |= MOD_META; @@ -1183,7 +1182,7 @@ x_event_to_emacs_event (XEvent *x_event, struct Lisp_Event *emacs_event) l_type = Qdragdrop_MIME; l_dndlist = list1 ( list3 ( list1 ( make_string ((Bufbyte *)"text/plain", 10) ), make_string ((Bufbyte *)"8bit", 4), - make_ext_string ((Extbyte *)data, + make_ext_string ((Extbyte *)data, strlen((char *)data), FORMAT_CTEXT) ) ); break; @@ -1205,7 +1204,7 @@ x_event_to_emacs_event (XEvent *x_event, struct Lisp_Event *emacs_event) case DndLink: case DndExe: { - char *hurl = dnd_url_hexify_string (data, "file:"); + char *hurl = dnd_url_hexify_string ((char *) data, "file:"); l_dndlist = list1 ( make_string ((Bufbyte *)hurl, strlen (hurl)) ); @@ -1217,7 +1216,7 @@ x_event_to_emacs_event (XEvent *x_event, struct Lisp_Event *emacs_event) case DndURL: /* as it is a real URL it should already be escaped and escaping again will break them (cause % is unsave) */ - l_dndlist = list1 ( make_ext_string ((Extbyte *)data, + l_dndlist = list1 ( make_ext_string ((Extbyte *)data, strlen ((char *)data), FORMAT_FILENAME) ); l_type = Qdragdrop_URL; @@ -1595,7 +1594,7 @@ emacs_Xt_handle_magic_event (struct Lisp_Event *emacs_event) handle_client_message (f, event); break; - case VisibilityNotify: /* window visiblity has changed */ + case VisibilityNotify: /* window visibility has changed */ if (event->xvisibility.window == XtWindow (FRAME_X_SHELL_WIDGET (f))) { FRAME_X_TOTALLY_VISIBLE_P (f) = @@ -1694,7 +1693,7 @@ emacs_Xt_remove_timeout (int id) struct Xt_timeout *timeout, *t2; timeout = NULL; - + /* Find the timeout on the list of pending ones, if it's still there. */ if (pending_timeouts) { @@ -2897,18 +2896,18 @@ vars_of_event_Xt (void) init_what_input_once (); Xt_event_stream = xnew (struct event_stream); - Xt_event_stream->event_pending_p = emacs_Xt_event_pending_p; - Xt_event_stream->next_event_cb = emacs_Xt_next_event; - Xt_event_stream->handle_magic_event_cb= emacs_Xt_handle_magic_event; - Xt_event_stream->add_timeout_cb = emacs_Xt_add_timeout; - Xt_event_stream->remove_timeout_cb = emacs_Xt_remove_timeout; - Xt_event_stream->select_console_cb = emacs_Xt_select_console; - Xt_event_stream->unselect_console_cb = emacs_Xt_unselect_console; - Xt_event_stream->select_process_cb = emacs_Xt_select_process; - Xt_event_stream->unselect_process_cb = emacs_Xt_unselect_process; - Xt_event_stream->quit_p_cb = emacs_Xt_quit_p; - Xt_event_stream->create_stream_pair_cb= emacs_Xt_create_stream_pair; - Xt_event_stream->delete_stream_pair_cb= emacs_Xt_delete_stream_pair; + Xt_event_stream->event_pending_p = emacs_Xt_event_pending_p; + Xt_event_stream->next_event_cb = emacs_Xt_next_event; + Xt_event_stream->handle_magic_event_cb = emacs_Xt_handle_magic_event; + Xt_event_stream->add_timeout_cb = emacs_Xt_add_timeout; + Xt_event_stream->remove_timeout_cb = emacs_Xt_remove_timeout; + Xt_event_stream->select_console_cb = emacs_Xt_select_console; + Xt_event_stream->unselect_console_cb = emacs_Xt_unselect_console; + Xt_event_stream->select_process_cb = emacs_Xt_select_process; + Xt_event_stream->unselect_process_cb = emacs_Xt_unselect_process; + Xt_event_stream->quit_p_cb = emacs_Xt_quit_p; + Xt_event_stream->create_stream_pair_cb = emacs_Xt_create_stream_pair; + Xt_event_stream->delete_stream_pair_cb = emacs_Xt_delete_stream_pair; DEFVAR_BOOL ("modifier-keys-are-sticky", &modifier_keys_are_sticky /* *Non-nil makes modifier keys sticky. diff --git a/src/event-msw.c b/src/event-msw.c index f31da31..e6e87d1 100644 --- a/src/event-msw.c +++ b/src/event-msw.c @@ -155,7 +155,7 @@ static int mswindows_pending_timers_count; /* This structure is allocated by the main thread, and is deallocated in the thread upon exit. There are situations when a thread remains blocked for a long time, much longer than the lstream - exists. For exmaple, "start notepad" command is issued from the + exists. For example, "start notepad" command is issued from the shell, then the shell is closed by C-c C-d. Although the shell process exits, its output pipe will not get closed until the notepad process exits also, because it inherits the pipe form the @@ -194,7 +194,7 @@ DEFINE_LSTREAM_IMPLEMENTATION ("ntpipe-input", lstream_ntpipe_slurp, sizeof (struct ntpipe_slurp_stream)); /* This function is thread-safe, and is called from either thread - context. It serializes freeing shared dtata structure */ + context. It serializes freeing shared data structure */ static void slurper_free_shared_data_maybe (struct ntpipe_slurp_stream_shared_data* s) { @@ -268,7 +268,7 @@ slurp_thread (LPVOID vparam) if (s->die_p) break; - /* Block until the client finishes with retireving the rest of + /* Block until the client finishes with retrieving the rest of pipe data */ WaitForSingleObject (s->hev_thread, INFINITE); } @@ -619,7 +619,7 @@ struct winsock_stream OVERLAPPED ov; /* Overlapped I/O structure */ void* buffer; /* Buffer. Allocated for input stream only */ unsigned int bufsize; /* Number of bytes last read */ - unsigned int bufpos; /* Psition in buffer for next fetch */ + unsigned int bufpos; /* Position in buffer for next fetch */ unsigned int error_p :1; /* I/O Error seen */ unsigned int eof_p :1; /* EOF Error seen */ unsigned int pending_p :1; /* There is a pending I/O operation */ @@ -1168,7 +1168,7 @@ mswindows_unsafe_pump_events (Lisp_Object u_n_u_s_e_d) * neither are waitable handles checked. The function pumps * thus only dispatch events already queued, as well as those * resulted in dispatching thereof. This is done by setting - * module local variable mswidows_in_modal_loop to nonzero. + * module local variable mswindows_in_modal_loop to nonzero. * * Return value is Qt if no errors was trapped, or Qunbound if * there was an error. @@ -1186,7 +1186,7 @@ mswindows_unsafe_pump_events (Lisp_Object u_n_u_s_e_d) * If the value of mswindows_error_caught_in_modal_loop is not * nil already upon entry, the function just returns non-nil. * This situation means that a new event has been queued while - * cancleng mode. The event will be dequeued on the next regular + * in cancel mode. The event will be dequeued on the next regular * call of next-event; the pump is off since error is caught. * The caller must *unconditionally* cancel modal loop if the * value returned by this function is nil. Otherwise, everything @@ -1220,10 +1220,10 @@ mswindows_drain_windows_queue () } /* - * This is a special flavour of the mswindows_need_event function, + * This is a special flavor of the mswindows_need_event function, * used while in event pump. Actually, there is only kind of events * allowed while in event pump: a timer. An attempt to fetch any - * other event leads to a dealock, as there's no source of user input + * other event leads to a deadlock, as there's no source of user input * ('cause event pump mirrors windows modal loop, which is a sole * owner of thread message queue). * @@ -1367,7 +1367,7 @@ mswindows_need_event (int badly_p) { if (errno != EINTR) { - /* something bad happended */ + /* something bad happened */ assert(0); } } @@ -1401,7 +1401,7 @@ mswindows_need_event (int badly_p) else { int ix = active - WAIT_OBJECT_0; - /* First, try to find which process' ouptut has signaled */ + /* First, try to find which process' output has signaled */ struct Lisp_Process *p = get_process_from_usid (HANDLE_TO_USID (mswindows_waitable_handles[ix])); if (p != NULL) @@ -1412,7 +1412,7 @@ mswindows_need_event (int badly_p) else { /* None. This means that the process handle itself has signaled. - Remove the handle from the wait vector, and make status_ntoify + Remove the handle from the wait vector, and make status_notify note the exited process */ mswindows_waitable_handles [ix] = mswindows_waitable_handles [--mswindows_waitable_count]; @@ -1576,7 +1576,7 @@ mswindows_dde_callback (UINT uType, UINT uFmt, HCONV hconv, LRESULT WINAPI mswindows_wnd_proc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam) { - /* Note: Remember to initialise emacs_event and event before use. + /* Note: Remember to initialize emacs_event and event before use. This code calls code that can GC. You must GCPRO before calling such code. */ Lisp_Object emacs_event = Qnil; Lisp_Object fobj = Qnil; @@ -1860,13 +1860,13 @@ mswindows_wnd_proc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam) break; case WM_MOUSEMOVE: - /* Optimization: don't report mouse movement while size is changind */ + /* Optimization: don't report mouse movement while size is changing */ msframe = FRAME_MSWINDOWS_DATA (XFRAME (mswindows_find_frame (hwnd))); if (!msframe->sizing) { /* When waiting for the second mouse button to finish button2 emulation, and have moved too far, just pretend - as if timer has expired. This impoves drag-select feedback */ + as if timer has expired. This improves drag-select feedback */ if ((msframe->button2_need_lbutton || msframe->button2_need_rbutton) && !mswindows_button2_near_enough (msframe->last_click_point, MAKEPOINTS (lParam))) @@ -2802,7 +2802,7 @@ Number of physical mouse buttons. DEFVAR_INT ("mswindows-mouse-button-max-skew-x", &mswindows_mouse_button_max_skew_x /* *Maximum horizontal distance in pixels between points in which left and -right button clicks occured for them to be translated into single +right button clicks occurred for them to be translated into single middle button event. Clicks must occur in time not longer than defined by the variable `mswindows-mouse-button-tolerance'. If negative or zero, currently set system default is used instead. @@ -2810,7 +2810,7 @@ If negative or zero, currently set system default is used instead. DEFVAR_INT ("mswindows-mouse-button-max-skew-y", &mswindows_mouse_button_max_skew_y /* *Maximum vertical distance in pixels between points in which left and -right button clicks occured for them to be translated into single +right button clicks occurred for them to be translated into single middle button event. Clicks must occur in time not longer than defined by the variable `mswindows-mouse-button-tolerance'. If negative or zero, currently set system default is used instead. diff --git a/src/event-stream.c b/src/event-stream.c index b965a3f..2b955fe 100644 --- a/src/event-stream.c +++ b/src/event-stream.c @@ -47,9 +47,9 @@ Boston, MA 02111-1307, USA. */ sequence, without disturbing the key sequence composition, or the command builder structure representing it. - Someone should rethink univeral-argument and figure out how an + Someone should rethink universal-argument and figure out how an arbitrary command can influence the next command (universal-argument - or univeral-coding-system-argument) or the next key (hyperify). + or universal-coding-system-argument) or the next key (hyperify). Both C-h and Help in the middle of a key sequence should trigger prefix-help-command. help-char is stupid. Maybe we need @@ -249,7 +249,7 @@ Lisp_Object Vmenu_accelerator_modifiers; /* whether menu accelerators are enabled */ Lisp_Object Vmenu_accelerator_enabled; -/* keymap for auxillary menu accelerator functions */ +/* keymap for auxiliary menu accelerator functions */ Lisp_Object Vmenu_accelerator_map; Lisp_Object Qmenu_force; @@ -392,12 +392,12 @@ static Lisp_Object mark_command_builder (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct command_builder *builder = XCOMMAND_BUILDER (obj); - (markobj) (builder->prefix_events); - (markobj) (builder->current_events); - (markobj) (builder->most_current_event); - (markobj) (builder->last_non_munged_event); - (markobj) (builder->munge_me[0].first_mungeable_event); - (markobj) (builder->munge_me[1].first_mungeable_event); + markobj (builder->prefix_events); + markobj (builder->current_events); + markobj (builder->most_current_event); + markobj (builder->last_non_munged_event); + markobj (builder->munge_me[0].first_mungeable_event); + markobj (builder->munge_me[1].first_mungeable_event); return builder->console; } @@ -781,9 +781,9 @@ maybe_kbd_translate (Lisp_Object event) if (XEVENT_TYPE (event) != key_press_event) return; - if (!HASHTABLEP (Vkeyboard_translate_table)) + if (!HASH_TABLEP (Vkeyboard_translate_table)) return; - if (EQ (Fhashtable_fullness (Vkeyboard_translate_table), Qzero)) + if (EQ (Fhash_table_count (Vkeyboard_translate_table), Qzero)) return; c = event_to_character (XEVENT (event), 0, 0, 0); @@ -896,7 +896,7 @@ execute_help_form (struct command_builder *command_builder, help = Feval (Vhelp_form); if (STRINGP (help)) - internal_with_output_to_temp_buffer ("*Help*", + internal_with_output_to_temp_buffer (build_string ("*Help*"), print_help, help, Qnil); Fnext_command_event (event, Qnil); /* Remove the help from the frame */ @@ -1129,7 +1129,7 @@ static Lisp_Object mark_timeout (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct timeout *tm = (struct timeout *) XOPAQUE_DATA (obj); - (markobj) (tm->function); + markobj (tm->function); return tm->object; } @@ -1813,7 +1813,7 @@ investigate_frame_change (void) * get here and have it be non-nil. */ if (FRAMEP (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d))) - old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d); + old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d); else if (FRAMEP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d))) old_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); @@ -2324,7 +2324,6 @@ The returned event will be one of the following types: XCAR (XCDR (XCDR (Vlast_command_event_time))) = make_int (EMACS_USECS (t)); } - /* If this key came from the keyboard or from a keyboard macro, then it goes into the recent-keys and this-command-keys vectors. If this key came from the keyboard, and we're defining a keyboard @@ -2370,7 +2369,7 @@ echo area while this function is waiting for an event. The event returned will be a keyboard, mouse press, or mouse release event. If there are non-command events available (mouse motion, sub-process output, etc) then these will be executed (with `dispatch-event') and discarded. This -function is provided as a convenience; it is rougly equivalent to the lisp code +function is provided as a convenience; it is roughly equivalent to the lisp code (while (progn (next-event event prompt) @@ -2510,7 +2509,7 @@ A user event is a key press, button press, button release, or All of these routines install timeouts, so we clear the installed timeout as well. - Note: It's very easy to break the desired behaviours of these + Note: It's very easy to break the desired behaviors of these 3 routines. If you make any changes to anything in this area, run the regression tests at the bottom of the file. -- dmoore */ @@ -2774,7 +2773,7 @@ If sit-for is called from within a process filter function or timer if (noninteractive || !NILP (Vexecuting_macro)) return Qnil; - /* Recusive call from a filter function or timeout handler. */ + /* Recursive call from a filter function or timeout handler. */ if (!NILP(recursive_sit_for)) { if (!event_stream_event_pending_p (1) && NILP (nodisplay)) @@ -4002,7 +4001,7 @@ Set the maximum number of events to be stored internally. /* Vthis_command_keys having value Qnil means that the next time push_this_command_keys is called, it should start over. The times at which the command-keys are reset - (instead of merely being augmented) are pretty conterintuitive. + (instead of merely being augmented) are pretty counterintuitive. (More specifically: -- We do not reset this-command-keys when we finish reading a @@ -4353,7 +4352,7 @@ execute_command_event (struct command_builder *command_builder, ; else #endif - if (!NILP (con->prefix_arg)) + if (!NILP (con->prefix_arg)) { /* Commands that set the prefix arg don't update last-command, don't reset the echoing state, and don't go into keyboard macros unless @@ -4969,16 +4968,6 @@ syms_of_event_stream (void) void vars_of_event_stream (void) { -#ifdef HAVE_X_WINDOWS - vars_of_event_Xt (); -#endif -#if defined(HAVE_TTY) && (defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS)) - vars_of_event_tty (); -#endif -#ifdef HAVE_MS_WINDOWS - vars_of_event_mswindows (); -#endif - recent_keys_ring_index = 0; recent_keys_ring_size = 100; Vrecent_keys_ring = Qnil; @@ -5340,7 +5329,8 @@ See also menu-accelerator-modifiers and menu-accelerator-prefix. void complex_vars_of_event_stream (void) { - Vkeyboard_translate_table = Fmake_hashtable (make_int (100), Qnil); + Vkeyboard_translate_table = + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); DEFVAR_LISP ("menu-accelerator-map", &Vmenu_accelerator_map /* Keymap for use when the menubar is active. @@ -5464,7 +5454,7 @@ with the read-key-sequence: (tst)^Jabc^G ==> ((quit) 97) with no signal, and "bc" inserted in buffer ; with sit-for only do the 2nd test. -; Do all 3 tests with (accept-proccess-output nil 20) +; Do all 3 tests with (accept-process-output nil 20) Do this: (setq enable-recursive-minibuffers t diff --git a/src/events.c b/src/events.c index 5727037..6fe8e6e 100644 --- a/src/events.c +++ b/src/events.c @@ -110,22 +110,22 @@ mark_event (Lisp_Object obj, void (*markobj) (Lisp_Object)) switch (event->event_type) { case key_press_event: - ((markobj) (event->event.key.keysym)); + markobj (event->event.key.keysym); break; case process_event: - ((markobj) (event->event.process.process)); + markobj (event->event.process.process); break; case timeout_event: - ((markobj) (event->event.timeout.function)); - ((markobj) (event->event.timeout.object)); + markobj (event->event.timeout.function); + markobj (event->event.timeout.object); break; case eval_event: case misc_user_event: - ((markobj) (event->event.eval.function)); - ((markobj) (event->event.eval.object)); + markobj (event->event.eval.function); + markobj (event->event.eval.object); break; case magic_eval_event: - ((markobj) (event->event.magic_eval.object)); + markobj (event->event.magic_eval.object); break; case button_press_event: case button_release_event: @@ -137,7 +137,7 @@ mark_event (Lisp_Object obj, void (*markobj) (Lisp_Object)) default: abort (); } - ((markobj) (event->channel)); + markobj (event->channel); return event->next; } @@ -154,7 +154,7 @@ static void print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { if (print_readably) - error ("printing unreadable object #"); + error ("Printing unreadable object #"); switch (XEVENT (obj)->event_type) { @@ -219,16 +219,18 @@ print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } static int -event_equal (Lisp_Object o1, Lisp_Object o2, int depth) +event_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Event *e1 = XEVENT (o1); - struct Lisp_Event *e2 = XEVENT (o2); + struct Lisp_Event *e1 = XEVENT (obj1); + struct Lisp_Event *e2 = XEVENT (obj2); if (e1->event_type != e2->event_type) return 0; if (!EQ (e1->channel, e2->channel)) return 0; /* if (e1->timestamp != e2->timestamp) return 0; */ switch (e1->event_type) { + default: abort (); + case process_event: return EQ (e1->event.process.process, e2->event.process.process); @@ -284,14 +286,14 @@ event_equal (Lisp_Object o1, Lisp_Object o2, int depth) #endif #ifdef HAVE_TTY if (CONSOLE_TTY_P (con)) - return (e1->event.magic.underlying_tty_event == - e2->event.magic.underlying_tty_event); + return (e1->event.magic.underlying_tty_event == + e2->event.magic.underlying_tty_event); #endif #ifdef HAVE_MS_WINDOWS if (CONSOLE_MSWINDOWS_P (con)) - return (!memcmp(&e1->event.magic.underlying_mswindows_event, - &e2->event.magic.underlying_mswindows_event, - sizeof(union magic_data))); + return (!memcmp(&e1->event.magic.underlying_mswindows_event, + &e2->event.magic.underlying_mswindows_event, + sizeof(union magic_data))); #endif return 1; /* not reached */ } @@ -299,10 +301,6 @@ event_equal (Lisp_Object o1, Lisp_Object o2, int depth) case empty_event: /* Empty and deallocated events are equal. */ case dead_event: return 1; - - default: - abort (); - return 0; /* not reached; warning suppression */ } } @@ -512,45 +510,45 @@ WARNING: the event object returned may be a reused one; see the function } else if (EQ (keyword, Qkey)) { - if (e->event_type != key_press_event) - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - if (!SYMBOLP (value) && !CHARP (value)) - signal_simple_error ("Invalid event key", value); - e->event.key.keysym = value; + switch (e->event_type) + { + case key_press_event: + if (!SYMBOLP (value) && !CHARP (value)) + signal_simple_error ("Invalid event key", value); + e->event.key.keysym = value; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else if (EQ (keyword, Qbutton)) { - if (e->event_type != button_press_event - && e->event_type != button_release_event - && e->event_type != misc_user_event) + CHECK_NATNUM (value); + check_int_range (XINT (value), 0, 7); + + switch (e->event_type) { + case button_press_event: + case button_release_event: + e->event.button.button = XINT (value); + break; + case misc_user_event: + e->event.misc.button = XINT (value); + break; + default: WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; } - CHECK_NATNUM (value); - check_int_range (XINT (value), 0, 7); - if (e->event_type == misc_user_event) - e->event.misc.button = XINT (value); - else - e->event.button.button = XINT (value); } else if (EQ (keyword, Qmodifiers)) { - Lisp_Object modtail; int modifiers = 0; + Lisp_Object sym; - if (e->event_type != key_press_event - && e->event_type != button_press_event - && e->event_type != button_release_event - && e->event_type != pointer_motion_event - && e->event_type != misc_user_event) - { - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - } - - EXTERNAL_LIST_LOOP (modtail, value) + EXTERNAL_LIST_LOOP_2 (sym, value) { - Lisp_Object sym = XCAR (modtail); - if (EQ (sym, Qcontrol)) modifiers |= MOD_CONTROL; + if (EQ (sym, Qcontrol)) modifiers |= MOD_CONTROL; else if (EQ (sym, Qmeta)) modifiers |= MOD_META; else if (EQ (sym, Qsuper)) modifiers |= MOD_SUPER; else if (EQ (sym, Qhyper)) modifiers |= MOD_HYPER; @@ -560,42 +558,61 @@ WARNING: the event object returned may be a reused one; see the function else signal_simple_error ("Invalid key modifier", sym); } - if (e->event_type == key_press_event) - e->event.key.modifiers = modifiers; - else if (e->event_type == button_press_event - || e->event_type == button_release_event) - e->event.button.modifiers = modifiers; - else if (e->event_type == pointer_motion_event) - e->event.motion.modifiers = modifiers; - else /* misc_user_event */ - e->event.misc.modifiers = modifiers; + + switch (e->event_type) + { + case key_press_event: + e->event.key.modifiers = modifiers; + break; + case button_press_event: + case button_release_event: + e->event.button.modifiers = modifiers; + break; + case pointer_motion_event: + e->event.motion.modifiers = modifiers; + break; + case misc_user_event: + e->event.misc.modifiers = modifiers; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else if (EQ (keyword, Qx)) { - if (e->event_type != pointer_motion_event - && e->event_type != button_press_event - && e->event_type != button_release_event - && e->event_type != misc_user_event) + switch (e->event_type) { + case pointer_motion_event: + case button_press_event: + case button_release_event: + case misc_user_event: + /* Allow negative values, so we can specify toolbar + positions. */ + CHECK_INT (value); + coord_x = XINT (value); + break; + default: WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; } - /* Allow negative values, so we can specify toolbar - positions. */ - CHECK_INT (value); - coord_x = XINT (value); } else if (EQ (keyword, Qy)) { - if (e->event_type != pointer_motion_event - && e->event_type != button_press_event - && e->event_type != button_release_event - && e->event_type != misc_user_event) + switch (e->event_type) { + case pointer_motion_event: + case button_press_event: + case button_release_event: + case misc_user_event: + /* Allow negative values; see above. */ + CHECK_INT (value); + coord_y = XINT (value); + break; + default: WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; } - /* Allow negative values; see above. */ - CHECK_INT (value); - coord_y = XINT (value); } else if (EQ (keyword, Qtimestamp)) { @@ -604,15 +621,27 @@ WARNING: the event object returned may be a reused one; see the function } else if (EQ (keyword, Qfunction)) { - if (e->event_type != misc_user_event) - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - e->event.eval.function = value; + switch (e->event_type) + { + case misc_user_event: + e->event.eval.function = value; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else if (EQ (keyword, Qobject)) { - if (e->event_type != misc_user_event) - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - e->event.eval.object = value; + switch (e->event_type) + { + case misc_user_event: + e->event.eval.object = value; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else signal_simple_error_2 ("Invalid property", keyword, value); @@ -629,31 +658,28 @@ WARNING: the event object returned may be a reused one; see the function /* Fevent_properties, Fevent_x_pixel, etc. work with pixels relative to the frame, so we must adjust accordingly. */ - if (e->event_type == pointer_motion_event - || e->event_type == button_press_event - || e->event_type == button_release_event - || e->event_type == misc_user_event) + if (FRAMEP (EVENT_CHANNEL (e))) { - struct frame *f = XFRAME (EVENT_CHANNEL (e)); + coord_x += FRAME_REAL_LEFT_TOOLBAR_WIDTH (XFRAME (EVENT_CHANNEL (e))); + coord_y += FRAME_REAL_TOP_TOOLBAR_HEIGHT (XFRAME (EVENT_CHANNEL (e))); - coord_x += FRAME_REAL_LEFT_TOOLBAR_WIDTH (f); - coord_y += FRAME_REAL_TOP_TOOLBAR_HEIGHT (f); - - if (e->event_type == pointer_motion_event) + switch (e->event_type) { + case pointer_motion_event: e->event.motion.x = coord_x; e->event.motion.y = coord_y; - } - else if (e->event_type == button_press_event - || e->event_type == button_release_event) - { + break; + case button_press_event: + case button_release_event: e->event.button.x = coord_x; e->event.button.y = coord_y; - } - else if (e->event_type == misc_user_event) - { + break; + case misc_user_event: e->event.misc.x = coord_x; e->event.misc.y = coord_y; + break; + default: + abort(); } } @@ -661,20 +687,20 @@ WARNING: the event object returned may be a reused one; see the function switch (e->event_type) { case key_press_event: - if (UNBOUNDP (e->event.key.keysym) - || !(SYMBOLP (e->event.key.keysym) || CHARP (e->event.key.keysym))) - error ("Undefined key for keypress event"); + if (UNBOUNDP (e->event.key.keysym)) + error ("A key must be specified to make a keypress event"); break; case button_press_event: + if (!e->event.button.button) + error ("A button must be specified to make a button-press event"); + break; case button_release_event: if (!e->event.button.button) - error ("Undefined button for %s event", - e->event_type == button_press_event - ? "buton-press" : "button-release"); + error ("A button must be specified to make a button-release event"); break; case misc_user_event: if (NILP (e->event.misc.function)) - error ("Undefined function for misc-user event"); + error ("A function must be specified to make a misc-user event"); break; default: break; @@ -989,7 +1015,7 @@ character_to_event (Emchar c, struct Lisp_Event *event, struct console *con, } if (c >= 'A' && c <= 'Z') c -= 'A'-'a'; } -#if defined(HAVE_TTY) +#if defined(HAVE_TTY) else if (do_backspace_mapping && CHARP (con->tty_erase_char) && c == XCHAR (con->tty_erase_char)) k = QKbackspace; @@ -1253,8 +1279,8 @@ format_event_object (char *buf, struct Lisp_Event *event, int brief) default: abort (); } -#define modprint1(x) { strcpy (buf, (x)); buf += sizeof (x)-1; } -#define modprint(x,y) { if (brief) modprint1 (y) else modprint1 (x) } +#define modprint1(x) do { strcpy (buf, (x)); buf += sizeof (x)-1; } while (0) +#define modprint(x,y) do { if (brief) modprint1 (y); else modprint1 (x); } while (0) if (mod & MOD_CONTROL) modprint ("control-", "C-"); if (mod & MOD_META) modprint ("meta-", "M-"); if (mod & MOD_SUPER) modprint ("super-", "S-"); @@ -2077,6 +2103,8 @@ This is in the form of a property list (alternating keyword/value pairs). switch (e->event_type) { + default: abort (); + case process_event: props = cons3 (Qprocess, e->event.process.process, props); break; @@ -2127,10 +2155,6 @@ This is in the form of a property list (alternating keyword/value pairs). case empty_event: RETURN_UNGCPRO (Qnil); break; - - default: - abort (); - break; /* not reached; warning suppression */ } props = cons3 (Qchannel, Fevent_channel (event), props); diff --git a/src/events.h b/src/events.h index cdb0370..3968677 100644 --- a/src/events.h +++ b/src/events.h @@ -115,7 +115,7 @@ Boston, MA 02111-1307, USA. */ have a separate input fd per device). create_stream_pair_cb These callbacks are called by process code to - delete_stream_pair_cb create and delete a pait of input and output lstreams + delete_stream_pair_cb create and delete a pair of input and output lstreams which are used for subprocess I/O. quitp_cb A handler function called from the `QUIT' macro which @@ -269,11 +269,11 @@ Boston, MA 02111-1307, USA. */ ------------------------ Since there are many possible processes/event loop combinations, the event code - is responsible for creating an appropriare lstream type. The process + is responsible for creating an appropriate lstream type. The process implementation does not care about that implementation. The Create stream pair function is passed two void* values, which identify - process-dependant 'handles'. The process implementation uses these handles + process-dependent 'handles'. The process implementation uses these handles to communicate with child processes. The function must be prepared to receive handle types of any process implementation. Since there only one process implementation exists in a particular XEmacs configuration, preprocessing @@ -293,20 +293,20 @@ Boston, MA 02111-1307, USA. */ corresponding lstream should not be created. The return value of the function is a unique stream identifier. It is used - by processes implementation, in its platform-independant part. There is + by processes implementation, in its platform-independent part. There is the get_process_from_usid function, which returns process object given its USID. The event stream is responsible for converting its internal handle type into USID. Example is the TTY event stream. When a file descriptor signals input, the event loop must determine process to which the input is destined. Thus, - the imlementation uses process input stream file descriptor as USID, by + the implementation uses process input stream file descriptor as USID, by simply casting the fd value to USID type. There are two special USID values. One, USID_ERROR, indicates that the stream pair cannot be created. The second, USID_DONTHASH, indicates that streams are created, but the event stream does not wish to be able to find the process - by its USID. Specifically, if an event stream implementation never calss + by its USID. Specifically, if an event stream implementation never calls get_process_from_usid, this value should always be returned, to prevent accumulating useless information on USID to process relationship. */ @@ -454,7 +454,7 @@ struct Lisp_Event struct motion_data motion; struct process_data process; struct timeout_data timeout; - struct eval_data eval; /* misc_user_event no loger uses this */ + struct eval_data eval; /* misc_user_event no longer uses this */ struct misc_user_data misc; /* because it needs position information */ union magic_data magic; struct magic_eval_data magic_eval; @@ -519,16 +519,13 @@ extern Lisp_Object Qcancel_mode_internal; /* Maybe this should be trickier */ #define KEYSYM(x) (intern (x)) -Lisp_Object allocate_command_builder (Lisp_Object console); - +/* from events.c */ void format_event_object (char *buf, struct Lisp_Event *e, int brief); void character_to_event (Emchar c, struct Lisp_Event *event, struct console *con, int use_console_meta_flag, int do_backspace_mapping); -void enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object); void zero_event (struct Lisp_Event *e); - void deallocate_event_chain (Lisp_Object event); Lisp_Object event_chain_tail (Lisp_Object event); void enqueue_event (Lisp_Object event, Lisp_Object *head, Lisp_Object *tail); @@ -542,17 +539,18 @@ Lisp_Object event_chain_find_previous (Lisp_Object event_chain, Lisp_Object event); Lisp_Object event_chain_nth (Lisp_Object event_chain, int n); Lisp_Object copy_event_chain (Lisp_Object event_chain); - /* True if this is a non-internal event (keyboard press, menu, scrollbar, mouse button) */ int command_event_p (Lisp_Object event); - struct console *event_console_or_selected (Lisp_Object event); +/* from event-stream.c */ +Lisp_Object allocate_command_builder (Lisp_Object console); +void enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object); void event_stream_next_event (struct Lisp_Event *event); void event_stream_handle_magic_event (struct Lisp_Event *event); -void event_stream_select_console (struct console *c); -void event_stream_unselect_console (struct console *c); +void event_stream_select_console (struct console *con); +void event_stream_unselect_console (struct console *con); void event_stream_select_process (struct Lisp_Process *proc); void event_stream_unselect_process (struct Lisp_Process *proc); USID event_stream_create_stream_pair (void* inhandle, void* outhandle, @@ -583,7 +581,6 @@ int event_stream_generate_wakeup (unsigned int milliseconds, void event_stream_disable_wakeup (int id, int async_p); void event_stream_deal_with_async_timeout (int interval_id); -/* from signal.c */ int event_stream_add_async_timeout (EMACS_TIME thyme); void event_stream_remove_async_timeout (int id); @@ -601,7 +598,13 @@ void single_console_state (void); void any_console_state (void); int in_single_console_state (void); +extern int emacs_is_blocking; + +extern volatile int sigint_happened; + #ifdef HAVE_UNIXOID_EVENT_LOOP +/* from event-unixoid.c */ + /* Ceci n'est pas un pipe. */ extern int signal_event_pipe[]; @@ -615,7 +618,7 @@ int event_stream_unixoid_unselect_console (struct console *con); int event_stream_unixoid_select_process (struct Lisp_Process *proc); int event_stream_unixoid_unselect_process (struct Lisp_Process *proc); int read_event_from_tty_or_stream_desc (struct Lisp_Event *event, - struct console *c, int fd); + struct console *con, int fd); USID event_stream_unixoid_create_stream_pair (void* inhandle, void* outhandle, Lisp_Object* instream, Lisp_Object* outstream, @@ -628,10 +631,6 @@ USID event_stream_unixoid_delete_stream_pair (Lisp_Object instream, #endif /* HAVE_UNIXOID_EVENT_LOOP */ -extern int emacs_is_blocking; - -extern volatile int sigint_happened; - /* Define this if you want the tty event stream to be used when the first console is tty, even if HAVE_X_WINDOWS is defined */ /* #define DEBUG_TTY_EVENT_STREAM */ diff --git a/src/extents.c b/src/extents.c index aa0f4fc..1c7c5b3 100644 --- a/src/extents.c +++ b/src/extents.c @@ -222,7 +222,6 @@ Boston, MA 02111-1307, USA. */ #include "faces.h" #include "frame.h" #include "glyphs.h" -#include "hash.h" #include "insdel.h" #include "keymap.h" #include "opaque.h" @@ -536,7 +535,7 @@ gap_array_make_gap (Gap_Array *ga, int increment) int old_gap_size; /* If we have to get more space, get enough to last a while. We use - a geometric progession that saves on realloc space. */ + a geometric progression that saves on realloc space. */ increment += 100 + ga->numels / 8; ptr = (char *) xrealloc (ptr, @@ -914,15 +913,15 @@ static Lisp_Object mark_extent_auxiliary (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct extent_auxiliary *data = XEXTENT_AUXILIARY (obj); - ((markobj) (data->begin_glyph)); - ((markobj) (data->end_glyph)); - ((markobj) (data->invisible)); - ((markobj) (data->children)); - ((markobj) (data->read_only)); - ((markobj) (data->mouse_face)); - ((markobj) (data->initial_redisplay_function)); - ((markobj) (data->before_change_functions)); - ((markobj) (data->after_change_functions)); + markobj (data->begin_glyph); + markobj (data->end_glyph); + markobj (data->invisible); + markobj (data->children); + markobj (data->read_only); + markobj (data->mouse_face); + markobj (data->initial_redisplay_function); + markobj (data->before_change_functions); + markobj (data->after_change_functions); return data->parent; } @@ -976,10 +975,9 @@ static void soe_invalidate (Lisp_Object obj); static Lisp_Object mark_extent_info (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct extent_info *data = - (struct extent_info *) XEXTENT_INFO (obj); + struct extent_info *data = (struct extent_info *) XEXTENT_INFO (obj); int i; - Extent_List *list; + Extent_List *list = data->extents; /* Vbuffer_defaults and Vbuffer_local_symbols are buffer-like objects that are created specially and never have their extent @@ -990,7 +988,6 @@ mark_extent_info (Lisp_Object obj, void (*markobj) (Lisp_Object)) (Also the list can be zero when we're dealing with a destroyed buffer.) */ - list = data->extents; if (list) { for (i = 0; i < extent_list_num_els (list); i++) @@ -999,7 +996,7 @@ mark_extent_info (Lisp_Object obj, void (*markobj) (Lisp_Object)) Lisp_Object exobj; XSETEXTENT (exobj, extent); - ((markobj) (exobj)); + markobj (exobj); } } @@ -1608,7 +1605,7 @@ extent_changed_for_redisplay (EXTENT extent, int descendants_too, force the modeline to be updated. But how to determine whether a string is a `generated-modeline-string'? Looping through all buffers is not very efficient. Should we add all - `generated-modeline-string' strings to a hashtable? + `generated-modeline-string' strings to a hash table? Maybe efficiency is not the greatest concern here and there's no big loss in looping over the buffers. */ return; @@ -1824,7 +1821,7 @@ extent_in_region_p (EXTENT extent, Bytind from, Bytind to, Endpoint_Index start, end, exs, exe; int start_open, end_open; unsigned int all_extents_flags = flags & ME_ALL_EXTENTS_MASK; - unsigned int in_region_flags = flags & ME_IN_REGION_MASK; + unsigned int in_region_flags = flags & ME_IN_REGION_MASK; int retval; /* A zero-length region is treated as closed-closed. */ @@ -1834,31 +1831,30 @@ extent_in_region_p (EXTENT extent, Bytind from, Bytind to, flags &= ~ME_START_OPEN; } - switch (all_extents_flags) + /* So is a zero-length extent. */ + if (extent_start (extent) == extent_end (extent)) + start_open = 0, end_open = 0; + /* `all_extents_flags' will almost always be zero. */ + else if (all_extents_flags == 0) { - case ME_ALL_EXTENTS_CLOSED: - start_open = end_open = 0; break; - case ME_ALL_EXTENTS_OPEN: - start_open = end_open = 1; break; - case ME_ALL_EXTENTS_CLOSED_OPEN: - start_open = 0; end_open = 1; break; - case ME_ALL_EXTENTS_OPEN_CLOSED: - start_open = 1; end_open = 0; break; - default: start_open = extent_start_open_p (extent); - end_open = extent_end_open_p (extent); - break; + end_open = extent_end_open_p (extent); } - - /* So is a zero-length extent. */ - if (extent_start (extent) == extent_end (extent)) - start_open = end_open = 0; + else + switch (all_extents_flags) + { + case ME_ALL_EXTENTS_CLOSED: start_open = 0, end_open = 0; break; + case ME_ALL_EXTENTS_OPEN: start_open = 1, end_open = 1; break; + case ME_ALL_EXTENTS_CLOSED_OPEN: start_open = 0, end_open = 1; break; + case ME_ALL_EXTENTS_OPEN_CLOSED: start_open = 1, end_open = 0; break; + default: abort(); break; + } start = buffer_or_string_bytind_to_startind (obj, from, flags & ME_START_OPEN); end = buffer_or_string_bytind_to_endind (obj, to, ! (flags & ME_END_CLOSED)); exs = memind_to_startind (extent_start (extent), start_open); - exe = memind_to_endind (extent_end (extent), end_open); + exe = memind_to_endind (extent_end (extent), end_open); /* It's easy to determine whether an extent lies *outside* the region -- just determine whether it's completely before @@ -1870,20 +1866,24 @@ extent_in_region_p (EXTENT extent, Bytind from, Bytind to, return 0; /* See if any further restrictions are called for. */ - switch (in_region_flags) - { - case ME_START_IN_REGION: - retval = start <= exs && exs <= end; break; - case ME_END_IN_REGION: - retval = start <= exe && exe <= end; break; - case ME_START_AND_END_IN_REGION: - retval = start <= exs && exe <= end; break; - case ME_START_OR_END_IN_REGION: - retval = (start <= exs && exs <= end) || (start <= exe && exe <= end); - break; - default: - retval = 1; break; - } + /* in_region_flags will almost always be zero. */ + if (in_region_flags == 0) + retval = 1; + else + switch (in_region_flags) + { + case ME_START_IN_REGION: + retval = start <= exs && exs <= end; break; + case ME_END_IN_REGION: + retval = start <= exe && exe <= end; break; + case ME_START_AND_END_IN_REGION: + retval = start <= exs && exe <= end; break; + case ME_START_OR_END_IN_REGION: + retval = (start <= exs && exs <= end) || (start <= exe && exe <= end); + break; + default: + abort(); break; + } return flags & ME_NEGATE_IN_REGION ? !retval : retval; } @@ -2866,7 +2866,7 @@ extent_fragment_update (struct window *w, struct extent_fragment *ef, xzero (dummy_lhe_extent); set_extent_priority (&dummy_lhe_extent, mouse_highlight_priority); - /* Need to break up thefollowing expression, due to an */ + /* Need to break up the following expression, due to an */ /* error in the Digital UNIX 3.2g C compiler (Digital */ /* UNIX Compiler Driver 3.11). */ f = extent_mouse_face (lhe); @@ -2942,8 +2942,8 @@ mark_extent (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct extent *extent = XEXTENT (obj); - ((markobj) (extent_object (extent))); - ((markobj) (extent_no_chase_normal_field (extent, face))); + markobj (extent_object (extent)); + markobj (extent_no_chase_normal_field (extent, face)); return extent->plist; } @@ -2995,7 +2995,7 @@ print_extent_1 (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) write_c_string (" ", printcharfun); } - sprintf (buf, "0x%lx", (unsigned long int) ext); + sprintf (buf, "0x%lx", (long) ext); write_c_string (buf, printcharfun); } @@ -3042,8 +3042,8 @@ print_extent (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) if (!EXTENT_LIVE_P (XEXTENT (obj))) error ("printing unreadable object #"); else - error ("printing unreadable object #", - XEXTENT (obj)); + error ("printing unreadable object #", + (long) XEXTENT (obj)); } if (!EXTENT_LIVE_P (XEXTENT (obj))) @@ -3106,13 +3106,13 @@ properties_equal (EXTENT e1, EXTENT e2, int depth) } static int -extent_equal (Lisp_Object o1, Lisp_Object o2, int depth) +extent_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct extent *e1 = XEXTENT (o1); - struct extent *e2 = XEXTENT (o2); + struct extent *e1 = XEXTENT (obj1); + struct extent *e2 = XEXTENT (obj2); return (extent_start (e1) == extent_start (e2) && - extent_end (e1) == extent_end (e2) && + extent_end (e1) == extent_end (e2) && internal_equal (extent_object (e1), extent_object (e2), depth + 1) && properties_equal (extent_ancestor (e1), extent_ancestor (e2), depth)); @@ -4748,7 +4748,7 @@ memoize_extent_face_internal (Lisp_Object list) on the keys so the memoization works correctly. Note that we canonicalize things so that the keys in the - hashtable (the external lists) always contain symbols and + hash table (the external lists) always contain symbols and the values (the internal lists) always contain face objects. We also maintain a "reverse" table that maps from the internal @@ -4998,7 +4998,7 @@ symbol_to_glyph_layout (Lisp_Object layout_obj) if (EQ (layout_obj, Qwhitespace)) return GL_WHITESPACE; if (EQ (layout_obj, Qtext)) return GL_TEXT; - signal_simple_error ("unknown glyph layout type", layout_obj); + signal_simple_error ("Unknown glyph layout type", layout_obj); return GL_TEXT; /* unreached */ } @@ -5325,23 +5325,15 @@ The following symbols have predefined meanings: Fset_extent_begin_glyph (extent, value, Qnil); else if (EQ (property, Qend_glyph)) Fset_extent_end_glyph (extent, value, Qnil); - else if (EQ (property, Qstart_open) || - EQ (property, Qend_open) || - EQ (property, Qstart_closed) || - EQ (property, Qend_closed)) - { - int start_open = -1, end_open = -1; - if (EQ (property, Qstart_open)) - start_open = !NILP (value); - else if (EQ (property, Qend_open)) - end_open = !NILP (value); - /* Support (but don't document...) the obvious antonyms. */ - else if (EQ (property, Qstart_closed)) - start_open = NILP (value); - else - end_open = NILP (value); - set_extent_openness (e, start_open, end_open); - } + else if (EQ (property, Qstart_open)) + set_extent_openness (e, !NILP (value), -1); + else if (EQ (property, Qend_open)) + set_extent_openness (e, -1, !NILP (value)); + /* Support (but don't document...) the obvious *_closed antonyms. */ + else if (EQ (property, Qstart_closed)) + set_extent_openness (e, NILP (value), -1); + else if (EQ (property, Qend_closed)) + set_extent_openness (e, -1, NILP (value)); else { if (EQ (property, Qkeymap)) @@ -5387,18 +5379,21 @@ See `set-extent-property' for the built-in property names. { EXTENT e = decode_extent (extent, 0); - if (EQ (property, Qdetached)) + if (EQ (property, Qdetached)) return extent_detached_p (e) ? Qt : Qnil; else if (EQ (property, Qdestroyed)) return !EXTENT_LIVE_P (e) ? Qt : Qnil; -#define RETURN_FLAG(flag) return extent_normal_field (e, flag) ? Qt : Qnil - else if (EQ (property, Qstart_open)) RETURN_FLAG (start_open); - else if (EQ (property, Qend_open)) RETURN_FLAG (end_open); - else if (EQ (property, Qunique)) RETURN_FLAG (unique); - else if (EQ (property, Qduplicable)) RETURN_FLAG (duplicable); - else if (EQ (property, Qdetachable)) RETURN_FLAG (detachable); -#undef RETURN_FLAG - /* Support (but don't document...) the obvious antonyms. */ + else if (EQ (property, Qstart_open)) + return extent_normal_field (e, start_open) ? Qt : Qnil; + else if (EQ (property, Qend_open)) + return extent_normal_field (e, end_open) ? Qt : Qnil; + else if (EQ (property, Qunique)) + return extent_normal_field (e, unique) ? Qt : Qnil; + else if (EQ (property, Qduplicable)) + return extent_normal_field (e, duplicable) ? Qt : Qnil; + else if (EQ (property, Qdetachable)) + return extent_normal_field (e, detachable) ? Qt : Qnil; + /* Support (but don't document...) the obvious *_closed antonyms. */ else if (EQ (property, Qstart_closed)) return extent_start_open_p (e) ? Qnil : Qt; else if (EQ (property, Qend_closed)) @@ -5755,12 +5750,10 @@ add_string_extents_mapper (EXTENT extent, void *arg) struct add_string_extents_arg *closure = (struct add_string_extents_arg *) arg; Bytecount start = extent_endpoint_bytind (extent, 0) - closure->from; - Bytecount end = extent_endpoint_bytind (extent, 1) - closure->from; + Bytecount end = extent_endpoint_bytind (extent, 1) - closure->from; if (extent_duplicable_p (extent)) { - EXTENT e; - start = max (start, 0); end = min (end, closure->length); @@ -5771,7 +5764,7 @@ add_string_extents_mapper (EXTENT extent, void *arg) !run_extent_copy_function (extent, start + closure->from, end + closure->from)) return 0; - e = copy_extent (extent, start, end, closure->string); + copy_extent (extent, start, end, closure->string); } return 0; @@ -5896,25 +5889,21 @@ copy_string_extents_mapper (EXTENT extent, void *arg) { struct copy_string_extents_arg *closure = (struct copy_string_extents_arg *) arg; - Bytecount old_start, old_end; - Bytecount new_start, new_end; + Bytecount old_start, old_end, new_start, new_end; old_start = extent_endpoint_bytind (extent, 0); - old_end = extent_endpoint_bytind (extent, 1); + old_end = extent_endpoint_bytind (extent, 1); old_start = max (closure->old_pos, old_start); - old_end = min (closure->old_pos + closure->length, old_end); + old_end = min (closure->old_pos + closure->length, old_end); if (old_start >= old_end) return 0; new_start = old_start + closure->new_pos - closure->old_pos; - new_end = old_end + closure->new_pos - closure->old_pos; + new_end = old_end + closure->new_pos - closure->old_pos; - copy_extent (extent, - old_start + closure->new_pos - closure->old_pos, - old_end + closure->new_pos - closure->old_pos, - closure->new_string); + copy_extent (extent, new_start, new_end, closure->new_string); return 0; } @@ -6514,7 +6503,7 @@ Used as the `paste-function' property of `text-prop' extents. prop = Fextent_property (extent, Qtext_prop, Qnil); if (NILP (prop)) - signal_simple_error ("internal error: no text-prop", extent); + signal_simple_error ("Internal error: no text-prop", extent); val = Fextent_property (extent, prop, Qnil); #if 0 /* removed by bill perry, 2/9/97 @@ -6522,7 +6511,7 @@ Used as the `paste-function' property of `text-prop' extents. ** with a value of Qnil. This is bad bad bad. */ if (NILP (val)) - signal_simple_error_2 ("internal error: no text-prop", + signal_simple_error_2 ("Internal error: no text-prop", extent, prop); #endif Fput_text_property (from, to, prop, val, Qnil); @@ -6814,7 +6803,7 @@ See `set-extent-priority'. /* Set mouse-highlight-priority (which ends up being used both for the mouse-highlighting pseudo-extent and the primary selection extent) to a very high value because very few extents should override it. - 1000 gives lots of room below it for different-prioritied extents. + 1000 gives lots of room below it for different-prioritized extents. 10 doesn't. ediff, for example, likes to use priorities around 100. --ben */ mouse_highlight_priority = /* 10 */ 1000; @@ -6850,14 +6839,14 @@ void complex_vars_of_extents (void) { staticpro (&Vextent_face_memoize_hash_table); - /* The memoize hash-table maps from lists of symbols to lists of + /* The memoize hash table maps from lists of symbols to lists of faces. It needs to be `equal' to implement the memoization. The reverse table maps in the other direction and just needs to do `eq' comparison because the lists of faces are already memoized. */ Vextent_face_memoize_hash_table = - make_lisp_hashtable (100, HASHTABLE_VALUE_WEAK, HASHTABLE_EQUAL); + make_lisp_hash_table (100, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL); staticpro (&Vextent_face_reverse_memoize_hash_table); Vextent_face_reverse_memoize_hash_table = - make_lisp_hashtable (100, HASHTABLE_KEY_WEAK, HASHTABLE_EQ); + make_lisp_hash_table (100, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); } diff --git a/src/extents.h b/src/extents.h index be0d6e4..457031e 100644 --- a/src/extents.h +++ b/src/extents.h @@ -103,8 +103,8 @@ struct extent #define extent_object(e) ((e)->object) #define extent_start(e) ((e)->start + 0) #define extent_end(e) ((e)->end + 0) -#define set_extent_start(e, val) ((e)->start = (val)) -#define set_extent_end(e, val) ((e)->end = (val)) +#define set_extent_start(e, val) ((void) ((e)->start = (val))) +#define set_extent_end(e, val) ((void) ((e)->end = (val))) #define extent_endpoint(e, endp) ((endp) ? extent_end (e) : extent_start (e)) #define set_extent_endpoint(e, val, endp) \ ((endp) ? set_extent_end (e, val) : set_extent_start (e, val)) diff --git a/src/faces.c b/src/faces.c index dc694dd..3ec7039 100644 --- a/src/faces.c +++ b/src/faces.c @@ -36,7 +36,6 @@ Boston, MA 02111-1307, USA. */ #include "faces.h" #include "frame.h" #include "glyphs.h" -#include "hash.h" #include "objects.h" #include "specifier.h" #include "window.h" @@ -78,22 +77,22 @@ mark_face (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Face *face = XFACE (obj); - ((markobj) (face->name)); - ((markobj) (face->doc_string)); + markobj (face->name); + markobj (face->doc_string); - ((markobj) (face->foreground)); - ((markobj) (face->background)); - ((markobj) (face->font)); - ((markobj) (face->display_table)); - ((markobj) (face->background_pixmap)); - ((markobj) (face->underline)); - ((markobj) (face->strikethru)); - ((markobj) (face->highlight)); - ((markobj) (face->dim)); - ((markobj) (face->blinking)); - ((markobj) (face->reverse)); + markobj (face->foreground); + markobj (face->background); + markobj (face->font); + markobj (face->display_table); + markobj (face->background_pixmap); + markobj (face->underline); + markobj (face->strikethru); + markobj (face->highlight); + markobj (face->dim); + markobj (face->blinking); + markobj (face->reverse); - ((markobj) (face->charsets_warned_about)); + markobj (face->charsets_warned_about); return face->plist; } @@ -129,10 +128,10 @@ print_face (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) This isn't concerned with "unspecified" attributes, that's what #'face-differs-from-default-p is for. */ static int -face_equal (Lisp_Object o1, Lisp_Object o2, int depth) +face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Face *f1 = XFACE (o1); - struct Lisp_Face *f2 = XFACE (o2); + struct Lisp_Face *f1 = XFACE (obj1); + struct Lisp_Face *f2 = XFACE (obj2); depth++; @@ -375,19 +374,14 @@ struct face_list_closure }; static int -add_face_to_list_mapper (CONST void *hash_key, void *hash_contents, +add_face_to_list_mapper (Lisp_Object key, Lisp_Object value, void *face_list_closure) { /* This function can GC */ - Lisp_Object key, contents; - Lisp_Object *face_list; struct face_list_closure *fcl = (struct face_list_closure *) face_list_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - face_list = fcl->face_list; - *face_list = Fcons (XFACE (contents)->name, *face_list); + *(fcl->face_list) = Fcons (XFACE (value)->name, (*fcl->face_list)); return 0; } @@ -420,15 +414,12 @@ temporary_faces_list (void) static int -mark_face_as_clean_mapper (CONST void *hash_key, void *hash_contents, +mark_face_as_clean_mapper (Lisp_Object key, Lisp_Object value, void *flag_closure) { /* This function can GC */ - Lisp_Object key, contents; int *flag = (int *) flag_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - XFACE (contents)->dirty = *flag; + XFACE (value)->dirty = *flag; return 0; } @@ -1007,13 +998,13 @@ mark_face_cachels (face_cachel_dynarr *elements, for (i = 0; i < NUM_LEADING_BYTES; i++) if (!NILP (cachel->font[i]) && !UNBOUNDP (cachel->font[i])) - ((markobj) (cachel->font[i])); + markobj (cachel->font[i]); } - ((markobj) (cachel->face)); - ((markobj) (cachel->foreground)); - ((markobj) (cachel->background)); - ((markobj) (cachel->display_table)); - ((markobj) (cachel->background_pixmap)); + markobj (cachel->face); + markobj (cachel->foreground); + markobj (cachel->background); + markobj (cachel->display_table); + markobj (cachel->background_pixmap); } } @@ -1638,23 +1629,19 @@ face_property_was_changed (Lisp_Object face, Lisp_Object property, if (WINDOWP (locale)) { - struct frame *f = XFRAME (XWINDOW (locale)->frame); - MARK_FRAME_FACES_CHANGED (f); + MARK_FRAME_FACES_CHANGED (XFRAME (XWINDOW (locale)->frame)); } else if (FRAMEP (locale)) { - struct frame *f = XFRAME (locale); - MARK_FRAME_FACES_CHANGED (f); + MARK_FRAME_FACES_CHANGED (XFRAME (locale)); } else if (DEVICEP (locale)) { - struct device *d = XDEVICE (locale); - MARK_DEVICE_FRAMES_FACES_CHANGED (d); + MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (locale)); } else { Lisp_Object devcons, concons; - DEVICE_LOOP_NO_BREAK (devcons, concons) MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (XCAR (devcons))); } @@ -1846,10 +1833,10 @@ vars_of_faces (void) void complex_vars_of_faces (void) { - Vpermanent_faces_cache = make_lisp_hashtable (10, HASHTABLE_NONWEAK, - HASHTABLE_EQ); - Vtemporary_faces_cache = make_lisp_hashtable (0, HASHTABLE_WEAK, - HASHTABLE_EQ); + Vpermanent_faces_cache = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + Vtemporary_faces_cache = + make_lisp_hash_table (0, HASH_TABLE_WEAK, HASH_TABLE_EQ); /* Create the default face now so we know what it is immediately. */ @@ -1941,7 +1928,7 @@ complex_vars_of_faces (void) list1 (Fcons (Qnil, Qnil))); set_specifier_fallback (Fget (Vdefault_face, Qreverse, Qnil), list1 (Fcons (Qnil, Qnil))); - + /* gui-element is the parent face of all gui elements such as modeline, vertical divider and toolbar. */ Vgui_element_face = Fmake_face (Qgui_element, @@ -1984,7 +1971,7 @@ complex_vars_of_faces (void) set_specifier_fallback (Fget (Vmodeline_face, Qbackground_pixmap, Qnil), Fget (Vgui_element_face, Qbackground_pixmap, Qunbound)); - + /* toolbar is another gui element */ Vtoolbar_face = Fmake_face (Qtoolbar, build_string ("toolbar face"), diff --git a/src/faces.h b/src/faces.h index 7d4523e..d57e8ee 100644 --- a/src/faces.h +++ b/src/faces.h @@ -215,7 +215,7 @@ struct face_cachel right sort are available on the system. In this case, the whole program will just crash. For the moment, this is OK (for debugging purposes) but we should fix this by - storing a "blank font" if the instantation fails. */ + storing a "blank font" if the instantiation fails. */ unsigned int dirty :1; unsigned int updated :1; /* #### Of course we should use a bit array or something. */ @@ -260,7 +260,7 @@ EXFUN (Fget_face, 1); extern Lisp_Object Qstrikethru, Vbuilt_in_face_specifiers, Vdefault_face; extern Lisp_Object Vleft_margin_face, Vpointer_face, Vright_margin_face; -extern Lisp_Object Vtext_cursor_face, Vvertical_divider_face; +extern Lisp_Object Vtext_cursor_face, Vvertical_divider_face; extern Lisp_Object Vtoolbar_face, Vgui_element_face; void mark_all_faces_as_clean (void); diff --git a/src/file-coding.c b/src/file-coding.c index 48363a4..71feff2 100644 --- a/src/file-coding.c +++ b/src/file-coding.c @@ -75,7 +75,7 @@ Lisp_Object Qshort, Qno_ascii_eol, Qno_ascii_cntl, Qseven, Qlock_shift; #endif Lisp_Object Qencode, Qdecode; -Lisp_Object Vcoding_system_hashtable; +Lisp_Object Vcoding_system_hash_table; int enable_multibyte_characters; @@ -232,12 +232,12 @@ mark_coding_system (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Coding_System *codesys = XCODING_SYSTEM (obj); - (markobj) (CODING_SYSTEM_NAME (codesys)); - (markobj) (CODING_SYSTEM_DOC_STRING (codesys)); - (markobj) (CODING_SYSTEM_MNEMONIC (codesys)); - (markobj) (CODING_SYSTEM_EOL_LF (codesys)); - (markobj) (CODING_SYSTEM_EOL_CRLF (codesys)); - (markobj) (CODING_SYSTEM_EOL_CR (codesys)); + markobj (CODING_SYSTEM_NAME (codesys)); + markobj (CODING_SYSTEM_DOC_STRING (codesys)); + markobj (CODING_SYSTEM_MNEMONIC (codesys)); + markobj (CODING_SYSTEM_EOL_LF (codesys)); + markobj (CODING_SYSTEM_EOL_CRLF (codesys)); + markobj (CODING_SYSTEM_EOL_CR (codesys)); switch (CODING_SYSTEM_TYPE (codesys)) { @@ -245,15 +245,15 @@ mark_coding_system (Lisp_Object obj, void (*markobj) (Lisp_Object)) int i; case CODESYS_ISO2022: for (i = 0; i < 4; i++) - (markobj) (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i)); + markobj (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i)); if (codesys->iso2022.input_conv) { for (i = 0; i < Dynarr_length (codesys->iso2022.input_conv); i++) { struct charset_conversion_spec *ccs = Dynarr_atp (codesys->iso2022.input_conv, i); - (markobj) (ccs->from_charset); - (markobj) (ccs->to_charset); + markobj (ccs->from_charset); + markobj (ccs->to_charset); } } if (codesys->iso2022.output_conv) @@ -262,22 +262,22 @@ mark_coding_system (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct charset_conversion_spec *ccs = Dynarr_atp (codesys->iso2022.output_conv, i); - (markobj) (ccs->from_charset); - (markobj) (ccs->to_charset); + markobj (ccs->from_charset); + markobj (ccs->to_charset); } } break; case CODESYS_CCL: - (markobj) (CODING_SYSTEM_CCL_DECODE (codesys)); - (markobj) (CODING_SYSTEM_CCL_ENCODE (codesys)); + markobj (CODING_SYSTEM_CCL_DECODE (codesys)); + markobj (CODING_SYSTEM_CCL_ENCODE (codesys)); break; #endif /* MULE */ default: break; } - (markobj) (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys)); + markobj (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys)); return CODING_SYSTEM_POST_READ_CONVERSION (codesys); } @@ -344,11 +344,11 @@ eol_type_to_symbol (enum eol_type type) { switch (type) { + default: abort (); case EOL_LF: return Qlf; case EOL_CRLF: return Qcrlf; case EOL_CR: return Qcr; case EOL_AUTODETECT: return Qnil; - default: abort (); return Qnil; /* not reached */ } } @@ -439,7 +439,7 @@ associated coding system object is returned. else CHECK_SYMBOL (coding_system_or_name); - return Fgethash (coding_system_or_name, Vcoding_system_hashtable, Qnil); + return Fgethash (coding_system_or_name, Vcoding_system_hash_table, Qnil); } DEFUN ("get-coding-system", Fget_coding_system, 1, 1, 0, /* @@ -465,19 +465,15 @@ struct coding_system_list_closure }; static int -add_coding_system_to_list_mapper (CONST void *hash_key, void *hash_contents, +add_coding_system_to_list_mapper (Lisp_Object key, Lisp_Object value, void *coding_system_list_closure) { /* This function can GC */ - Lisp_Object key, contents; - Lisp_Object *coding_system_list; struct coding_system_list_closure *cscl = (struct coding_system_list_closure *) coding_system_list_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - coding_system_list = cscl->coding_system_list; + Lisp_Object *coding_system_list = cscl->coding_system_list; - *coding_system_list = Fcons (XCODING_SYSTEM (contents)->name, + *coding_system_list = Fcons (XCODING_SYSTEM (value)->name, *coding_system_list); return 0; } @@ -493,7 +489,7 @@ Return a list of the names of all defined coding systems. GCPRO1 (coding_system_list); coding_system_list_closure.coding_system_list = &coding_system_list; - elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hashtable, + elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hash_table, &coding_system_list_closure); UNGCPRO; @@ -890,7 +886,7 @@ if TYPE is 'ccl: { Lisp_Object codesys_obj; XSETCODING_SYSTEM (codesys_obj, codesys); - Fputhash (name, codesys_obj, Vcoding_system_hashtable); + Fputhash (name, codesys_obj, Vcoding_system_hash_table); return codesys_obj; } } @@ -911,7 +907,7 @@ be created. allocate_coding_system (XCODING_SYSTEM_TYPE (old_coding_system), new_name)); - Fputhash (new_name, new_coding_system, Vcoding_system_hashtable); + Fputhash (new_name, new_coding_system, Vcoding_system_hash_table); } { @@ -978,6 +974,7 @@ Return the type of CODING-SYSTEM. { switch (XCODING_SYSTEM_TYPE (Fget_coding_system (coding_system))) { + default: abort (); case CODESYS_AUTODETECT: return Qundecided; #ifdef MULE case CODESYS_SHIFT_JIS: return Qshift_jis; @@ -989,11 +986,7 @@ Return the type of CODING-SYSTEM. #ifdef DEBUG_XEMACS case CODESYS_INTERNAL: return Qinternal; #endif - default: - abort (); } - - return Qnil; /* not reached */ } #ifdef MULE @@ -1746,7 +1739,7 @@ decoding_marker (Lisp_Object stream, void (*markobj) (Lisp_Object)) and automatically marked. */ XSETLSTREAM (str_obj, str); - (markobj) (str_obj); + markobj (str_obj); if (str->imp->marker) return (str->imp->marker) (str_obj, markobj); else @@ -2192,7 +2185,7 @@ encoding_marker (Lisp_Object stream, void (*markobj) (Lisp_Object)) and automatically marked. */ XSETLSTREAM (str_obj, str); - (markobj) (str_obj); + markobj (str_obj); if (str->imp->marker) return (str->imp->marker) (str_obj, markobj); else @@ -2748,7 +2741,7 @@ Return the corresponding character code in SHIFT-JIS as a cons of two bytes. Since the number of characters in Big5 is larger than maximum characters in Emacs' charset (96x96), it can't be handled as one - charset. So, in Emacs, Big5 is devided into two: `charset-big5-1' + charset. So, in Emacs, Big5 is divided into two: `charset-big5-1' and `charset-big5-2'. Both s are TYPE94x94. The former contains frequently used characters and the latter contains less frequently used characters. */ @@ -4484,24 +4477,27 @@ static Bufbyte_dynarr *conversion_in_dynarr; /* Determine coding system from coding format */ -#define FILE_NAME_CODING_SYSTEM \ - ((NILP (Vfile_name_coding_system) || \ - (EQ ((Vfile_name_coding_system), Qbinary))) ? \ - Qnil : Fget_coding_system (Vfile_name_coding_system)) - /* #### not correct for all values of `fmt'! */ +static Lisp_Object +external_data_format_to_coding_system (enum external_data_format fmt) +{ + switch (fmt) + { + case FORMAT_FILENAME: + case FORMAT_TERMINAL: + if (EQ (Vfile_name_coding_system, Qnil) || + EQ (Vfile_name_coding_system, Qbinary)) + return Qnil; + else + return Fget_coding_system (Vfile_name_coding_system); #ifdef MULE -#define FMT_CODING_SYSTEM(fmt) \ - (((fmt) == FORMAT_FILENAME) ? FILE_NAME_CODING_SYSTEM : \ - ((fmt) == FORMAT_CTEXT ) ? Fget_coding_system (Qctext) : \ - ((fmt) == FORMAT_TERMINAL) ? FILE_NAME_CODING_SYSTEM : \ - Qnil) -#else -#define FMT_CODING_SYSTEM(fmt) \ - (((fmt) == FORMAT_FILENAME) ? FILE_NAME_CODING_SYSTEM : \ - ((fmt) == FORMAT_TERMINAL) ? FILE_NAME_CODING_SYSTEM : \ - Qnil) + case FORMAT_CTEXT: + return Fget_coding_system (Qctext); #endif + default: + return Qnil; + } +} Extbyte * convert_to_external_format (CONST Bufbyte *ptr, @@ -4509,7 +4505,7 @@ convert_to_external_format (CONST Bufbyte *ptr, Extcount *len_out, enum external_data_format fmt) { - Lisp_Object coding_system = FMT_CODING_SYSTEM (fmt); + Lisp_Object coding_system = external_data_format_to_coding_system (fmt); if (!conversion_out_dynarr) conversion_out_dynarr = Dynarr_new (Extbyte); @@ -4577,7 +4573,7 @@ convert_from_external_format (CONST Extbyte *ptr, Bytecount *len_out, enum external_data_format fmt) { - Lisp_Object coding_system = FMT_CODING_SYSTEM (fmt); + Lisp_Object coding_system = external_data_format_to_coding_system (fmt); if (!conversion_in_dynarr) conversion_in_dynarr = Dynarr_new (Bufbyte); @@ -4819,9 +4815,9 @@ Setting this to nil does not do anything. void complex_vars_of_mule_coding (void) { - staticpro (&Vcoding_system_hashtable); - Vcoding_system_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + staticpro (&Vcoding_system_hash_table); + Vcoding_system_hash_table = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); the_codesys_prop_dynarr = Dynarr_new (codesys_prop); diff --git a/src/file-coding.h b/src/file-coding.h index 2643f4c..a29e3ec 100644 --- a/src/file-coding.h +++ b/src/file-coding.h @@ -256,7 +256,7 @@ extern Lisp_Object Qmnemonic, Qno_ascii_cntl, Qno_ascii_eol, Qno_conversion; extern Lisp_Object Qno_iso6429, Qoutput_charset_conversion; extern Lisp_Object Qpost_read_conversion, Qpre_write_conversion, Qseven; extern Lisp_Object Qshift_jis, Qshort, Vcoding_system_for_read; -extern Lisp_Object Vcoding_system_for_write, Vcoding_system_hashtable; +extern Lisp_Object Vcoding_system_for_write, Vcoding_system_hash_table; extern Lisp_Object Vfile_name_coding_system, Vkeyboard_coding_system; extern Lisp_Object Vterminal_coding_system; diff --git a/src/fileio.c b/src/fileio.c index f46d1e0..a9db0b5 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -438,7 +438,7 @@ Given a Unix syntax file name, returns a string ending in slash. while (p != beg && !IS_ANY_SEP (p[-1]) #ifdef WINDOWSNT - /* only recognise drive specifier at beginning */ + /* only recognize drive specifier at beginning */ && !(p[-1] == ':' && p == beg + 2) #endif ) p--; @@ -493,7 +493,7 @@ or the entire name if it contains no slash. while (p != beg && !IS_ANY_SEP (p[-1]) #ifdef WINDOWSNT - /* only recognise drive specifier at beginning */ + /* only recognize drive specifier at beginning */ && !(p[-1] == ':' && p == beg + 2) #endif ) p--; @@ -742,18 +742,17 @@ be an absolute file name. /* We want to return only if errno is ENOENT. */ if (errno == ENOENT) return val; - else - /* The error here is dubious, but there is little else we - can do. The alternatives are to return nil, which is - as bad as (and in many cases worse than) throwing the - error, or to ignore the error, which will likely result - in inflooping. */ - report_file_error ("Cannot create temporary name for prefix", - list1 (prefix)); - /* not reached */ + + /* The error here is dubious, but there is little else we + can do. The alternatives are to return nil, which is + as bad as (and in many cases worse than) throwing the + error, or to ignore the error, which will likely result + in inflooping. */ + report_file_error ("Cannot create temporary name for prefix", + list1 (prefix)); + return Qnil; /* not reached */ } } - RETURN_NOT_REACHED (Qnil); } @@ -869,7 +868,7 @@ See also the function `substitute-in-file-name'. if (colon) /* Only recognize colon as part of drive specifier if there is a - single alphabetic character preceeding the colon (and if the + single alphabetic character preceding the colon (and if the character before the drive letter, if present, is a directory separator); this is to support the remote system syntax used by ange-ftp, and the "po:username" syntax for POP mailboxes. */ @@ -991,7 +990,8 @@ See also the function `substitute-in-file-name'. } else /* ~user/filename */ { - for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++); + for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++) + DO_NOTHING; o = (Bufbyte *) alloca (p - nm + 1); memcpy (o, (char *) nm, p - nm); o [p - nm] = 0; @@ -1018,13 +1018,13 @@ See also the function `substitute-in-file-name'. { /* Does the user login name match the ~name? */ if (strcmp(user,((char *) o + 1)) == 0) - { + { newdir = (Bufbyte *) get_home_directory(); nm = p; } } if (! newdir) - { + { #endif /* __CYGWIN32__ */ /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM occurring in it. (It can call select()). */ @@ -1770,7 +1770,7 @@ A prefix arg makes KEEP-TIME non-nil. } #endif /* S_ISREG && S_ISLNK */ - ofd = open( (char *) XSTRING_DATA (newname), + ofd = open( (char *) XSTRING_DATA (newname), O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE); if (ofd < 0) report_file_error ("Opening output file", list1 (newname)); @@ -2049,7 +2049,7 @@ This is what happens in interactive use with M-x. on NT here. --marcpa */ /* But FSF #defines link as sys_link which is supplied in nt.c. We can't do that because sysfile.h defines sys_link depending on ENCAPSULATE_LINK. - Reverted to previous behaviour pending a working fix. (jhar) */ + Reverted to previous behavior pending a working fix. (jhar) */ #if defined(WINDOWSNT) /* Windows does not support this operation. */ report_file_error ("Adding new name", Flist (2, &filename)); @@ -2525,7 +2525,7 @@ Return mode bits of FILE, as an integer. /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */ #if 0 #ifdef DOS_NT - if (check_executable (XSTRING (abspath)->_data)) + if (check_executable (XSTRING_DATA (abspath))) st.st_mode |= S_IEXEC; #endif /* DOS_NT */ #endif /* 0 */ @@ -3346,10 +3346,10 @@ to the value of CODESYS. If this is nil, no code conversion occurs. /* On VMS and APOLLO, must do the stat after the close since closing changes the modtime. */ /* As it does on Windows too - kkm */ - /* The spurious warnings appear on Linux too. Rather than handling + /* The spurious warnings appear on Linux too. Rather than handling this on a per-system basis, unconditionally do the stat after the close - cgw */ - -#if 0 /* !defined (WINDOWSNT) /* !defined (VMS) && !defined (APOLLO) */ + +#if 0 /* !defined (WINDOWSNT) */ /* !defined (VMS) && !defined (APOLLO) */ fstat (desc, &st); #endif @@ -3367,7 +3367,7 @@ to the value of CODESYS. If this is nil, no code conversion occurs. unbind_to (speccount, Qnil); } - /* # if defined (WINDOWSNT) /* defined (VMS) || defined (APOLLO) */ + /* # if defined (WINDOWSNT) */ /* defined (VMS) || defined (APOLLO) */ stat ((char *) XSTRING_DATA (fn), &st); /* #endif */ @@ -3429,7 +3429,10 @@ Return t if (car A) is numerically less than (car B). */ (a, b)) { - return arithcompare (Fcar (a), Fcar (b), arith_less); + Lisp_Object objs[2]; + objs[0] = Fcar (a); + objs[1] = Fcar (b); + return Flss (2, objs); } /* Heh heh heh, let's define this too, just to aggravate the person who @@ -3439,7 +3442,10 @@ Return t if (cdr A) is numerically less than (cdr B). */ (a, b)) { - return arithcompare (Fcdr (a), Fcdr (b), arith_less); + Lisp_Object objs[2]; + objs[0] = Fcdr (a); + objs[1] = Fcdr (b); + return Flss (2, objs); } /* Build the complete list of annotations appropriate for writing out @@ -3828,7 +3834,7 @@ auto_save_expand_name (Lisp_Object name) struct gcpro gcpro1; /* note that caller did NOT gc protect name, so we do it. */ - /* #### dmoore - this might not be neccessary, if condition_case_1 + /* #### dmoore - this might not be necessary, if condition_case_1 protects it. but I don't think it does. */ GCPRO1 (name); RETURN_UNGCPRO (Fexpand_file_name (name, Qnil)); diff --git a/src/floatfns.c b/src/floatfns.c index 61e942a..56a78a4 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -162,13 +162,13 @@ in_float_error (void) static Lisp_Object mark_float (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - return (Qnil); + return Qnil; } static int -float_equal (Lisp_Object o1, Lisp_Object o2, int depth) +float_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - return (extract_float (o1) == extract_float (o2)); + return (extract_float (obj1) == extract_float (obj2)); } static unsigned long @@ -188,11 +188,13 @@ DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float, double extract_float (Lisp_Object num) { - CHECK_INT_OR_FLOAT (num); - if (FLOATP (num)) - return (float_data (XFLOAT (num))); - return (double) XINT (num); + return XFLOAT_DATA (num); + + if (INTP (num)) + return (double) XINT (num); + + return extract_float (wrong_type_argument (num, Qnumberp)); } #endif /* LISP_FLOAT_TYPE */ @@ -422,53 +424,54 @@ Return the exponential ARG1 ** ARG2. */ (arg1, arg2)) { - double f1, f2; - - CHECK_INT_OR_FLOAT (arg1); - CHECK_INT_OR_FLOAT (arg2); - if ((INTP (arg1)) && /* common lisp spec */ - (INTP (arg2))) /* don't promote, if both are ints */ + if (INTP (arg1) && /* common lisp spec */ + INTP (arg2)) /* don't promote, if both are ints */ { - EMACS_INT acc, x, y; - x = XINT (arg1); - y = XINT (arg2); + EMACS_INT retval; + EMACS_INT x = XINT (arg1); + EMACS_INT y = XINT (arg2); if (y < 0) { if (x == 1) - acc = 1; + retval = 1; else if (x == -1) - acc = (y & 1) ? -1 : 1; + retval = (y & 1) ? -1 : 1; else - acc = 0; + retval = 0; } else { - acc = 1; + retval = 1; while (y > 0) { if (y & 1) - acc *= x; + retval *= x; x *= x; y = (EMACS_UINT) y >> 1; } } - return (make_int (acc)); + return make_int (retval); } + #ifdef LISP_FLOAT_TYPE - f1 = (FLOATP (arg1)) ? float_data (XFLOAT (arg1)) : XINT (arg1); - f2 = (FLOATP (arg2)) ? float_data (XFLOAT (arg2)) : XINT (arg2); - /* Really should check for overflow, too */ - if (f1 == 0.0 && f2 == 0.0) - f1 = 1.0; + { + double f1 = extract_float (arg1); + double f2 = extract_float (arg2); + /* Really should check for overflow, too */ + if (f1 == 0.0 && f2 == 0.0) + f1 = 1.0; # ifdef FLOAT_CHECK_DOMAIN - else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2))) - domain_error2 ("expt", arg1, arg2); + else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2))) + domain_error2 ("expt", arg1, arg2); # endif /* FLOAT_CHECK_DOMAIN */ - IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2); - return make_float (f1); -#else /* !LISP_FLOAT_TYPE */ - abort (); + IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2); + return make_float (f1); + } +#else + CHECK_INT_OR_FLOAT (arg1); + CHECK_INT_OR_FLOAT (arg2); + return Fexpt (arg1, arg2); #endif /* LISP_FLOAT_TYPE */ } @@ -651,21 +654,19 @@ Return the absolute value of ARG. */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - IN_FLOAT (arg = make_float ((double) fabs (float_data (XFLOAT (arg)))), - "abs", arg); - return (arg); - } - else + { + IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), + "abs", arg); + return arg; + } #endif /* LISP_FLOAT_TYPE */ - if (XINT (arg) < 0) - return (make_int (- XINT (arg))); - else - return (arg); + + if (INTP (arg)) + return (XINT (arg) >= 0) ? arg : make_int (- XINT (arg)); + + return Fabs (wrong_type_argument (arg, Qnumberp)); } #ifdef LISP_FLOAT_TYPE @@ -674,12 +675,13 @@ Return the floating point number equal to ARG. */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - if (INTP (arg)) return make_float ((double) XINT (arg)); - else /* give 'em the same float back */ + + if (FLOATP (arg)) /* give 'em the same float back */ return arg; + + return Ffloat (wrong_type_argument (arg, Qnumberp)); } #endif /* LISP_FLOAT_TYPE */ @@ -743,18 +745,19 @@ Return the smallest integer no less than ARG. (Round toward +inf.) */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - double d; - IN_FLOAT ((d = ceil (float_data (XFLOAT (arg)))), "ceiling", arg); - return (float_to_int (d, "ceiling", arg, Qunbound)); - } + { + double d; + IN_FLOAT ((d = ceil (XFLOAT_DATA (arg))), "ceiling", arg); + return (float_to_int (d, "ceiling", arg, Qunbound)); + } #endif /* LISP_FLOAT_TYPE */ - return arg; + if (INTP (arg)) + return arg; + + return Fceiling (wrong_type_argument (arg, Qnumberp)); } @@ -775,10 +778,9 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. #ifdef LISP_FLOAT_TYPE if (FLOATP (arg) || FLOATP (divisor)) { - double f1, f2; + double f1 = extract_float (arg); + double f2 = extract_float (divisor); - f1 = ((FLOATP (arg)) ? float_data (XFLOAT (arg)) : XINT (arg)); - f2 = ((FLOATP (divisor)) ? float_data (XFLOAT (divisor)) : XINT (divisor)); if (f2 == 0) Fsignal (Qarith_error, Qnil); @@ -804,11 +806,11 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR. #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - double d; - IN_FLOAT ((d = floor (float_data (XFLOAT (arg)))), "floor", arg); - return (float_to_int (d, "floor", arg, Qunbound)); - } + { + double d; + IN_FLOAT ((d = floor (XFLOAT_DATA (arg))), "floor", arg); + return (float_to_int (d, "floor", arg, Qunbound)); + } #endif /* LISP_FLOAT_TYPE */ return arg; @@ -819,19 +821,20 @@ Return the nearest integer to ARG. */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - double d; - /* Screw the prevailing rounding mode. */ - IN_FLOAT ((d = rint (float_data (XFLOAT (arg)))), "round", arg); - return (float_to_int (d, "round", arg, Qunbound)); - } + { + double d; + /* Screw the prevailing rounding mode. */ + IN_FLOAT ((d = rint (XFLOAT_DATA (arg))), "round", arg); + return (float_to_int (d, "round", arg, Qunbound)); + } #endif /* LISP_FLOAT_TYPE */ - return arg; + if (INTP (arg)) + return arg; + + return Fround (wrong_type_argument (arg, Qnumberp)); } DEFUN ("truncate", Ftruncate, 1, 1, 0, /* @@ -840,15 +843,15 @@ Rounds the value toward zero. */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - return (float_to_int (float_data (XFLOAT (arg)), - "truncate", arg, Qunbound)); + return float_to_int (XFLOAT_DATA (arg), "truncate", arg, Qunbound); #endif /* LISP_FLOAT_TYPE */ - return arg; + if (INTP (arg)) + return arg; + + return Ftruncate (wrong_type_argument (arg, Qnumberp)); } /* Float-rounding functions. */ diff --git a/src/fns.c b/src/fns.c index 2f30628..269ae5e 100644 --- a/src/fns.c +++ b/src/fns.c @@ -43,7 +43,6 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "bytecode.h" -#include "commands.h" #include "device.h" #include "events.h" #include "extents.h" @@ -91,10 +90,10 @@ print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } static int -bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) +bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1); - struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2); + struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); + struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); return ((bit_vector_length (v1) == bit_vector_length (v2)) && !memcmp (v1->bits, v2->bits, @@ -178,10 +177,10 @@ length_with_bytecode_hack (Lisp_Object seq) return XINT (Flength (seq)); else { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq); + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); - return (b->flags.interactivep ? COMPILED_INTERACTIVE : - b->flags.domainp ? COMPILED_DOMAIN : + return (f->flags.interactivep ? COMPILED_INTERACTIVE : + f->flags.domainp ? COMPILED_DOMAIN : COMPILED_DOC_STRING) + 1; } @@ -209,16 +208,9 @@ Return the length of vector, bit vector, list or string SEQUENCE. return make_int (XSTRING_CHAR_LENGTH (sequence)); else if (CONSP (sequence)) { - Lisp_Object tail; - int i = 0; - - EXTERNAL_LIST_LOOP (tail, sequence) - { - QUIT; - i++; - } - - return make_int (i); + int len; + GET_EXTERNAL_LIST_LENGTH (sequence, len); + return make_int (len); } else if (VECTORP (sequence)) return make_int (XVECTOR_LENGTH (sequence)); @@ -234,9 +226,6 @@ Return the length of vector, bit vector, list or string SEQUENCE. } } -/* This does not check for quits. That is safe - since it must terminate. */ - DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* 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, @@ -245,17 +234,15 @@ which is at least the number of distinct elements. */ (list)) { - Lisp_Object halftail = list; /* Used to detect circular lists. */ - Lisp_Object tail; - int len = 0; + Lisp_Object hare, tortoise; + int len; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + for (hare = tortoise = list, len = 0; + CONSP (hare) && (! EQ (hare, tortoise) || len == 0); + hare = XCDR (hare), len++) { - if (EQ (tail, halftail) && len != 0) - break; - len++; - if ((len & 1) == 0) - halftail = XCDR (halftail); + if (len & 1) + tortoise = XCDR (tortoise); } return make_int (len); @@ -511,38 +498,65 @@ arguments. Each argument may be a list, vector, bit vector, or string. return concat (nargs, args, c_bit_vector, 0); } -DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* -Return a copy of a list, vector, bit vector or string. -The elements of a list or vector are not copied; they are shared +/* Copy a (possibly dotted) list. LIST must be a cons. + Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */ +static Lisp_Object +copy_list (Lisp_Object list) +{ + Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); + Lisp_Object last = list_copy; + Lisp_Object hare, tortoise; + int len; + + for (tortoise = hare = XCDR (list), len = 1; + CONSP (hare); + hare = XCDR (hare), len++) + { + XCDR (last) = Fcons (XCAR (hare), XCDR (hare)); + last = XCDR (last); + + if (len < CIRCULAR_LIST_SUSPICION_LENGTH) + continue; + if (len & 1) + tortoise = XCDR (tortoise); + if (EQ (tortoise, hare)) + signal_circular_list_error (list); + } + + return list_copy; +} + +DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /* +Return a copy of list LIST, which may be a dotted list. +The elements of LIST are not copied; they are shared with the original. */ - (arg)) + (list)) { again: - if (NILP (arg)) return arg; - /* We handle conses separately because concat() is big and hairy and - doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this - than to fix concat() without worrying about breaking other things. - */ - if (CONSP (arg)) - { - Lisp_Object head = Fcons (XCAR (arg), XCDR (arg)); - Lisp_Object tail = head; + if (NILP (list)) return list; + if (CONSP (list)) return copy_list (list); - for (arg = XCDR (arg); CONSP (arg); arg = XCDR (arg)) - { - XCDR (tail) = Fcons (XCAR (arg), XCDR (arg)); - tail = XCDR (tail); - QUIT; - } - return head; - } - if (STRINGP (arg)) return concat (1, &arg, c_string, 0); - if (VECTORP (arg)) return concat (1, &arg, c_vector, 0); - if (BIT_VECTORP (arg)) return concat (1, &arg, c_bit_vector, 0); + list = wrong_type_argument (Qlistp, list); + goto again; +} - check_losing_bytecode ("copy-sequence", arg); - arg = wrong_type_argument (Qsequencep, arg); +DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* +Return a copy of list, vector, bit vector or string SEQUENCE. +The elements of a list or vector are not copied; they are shared +with the original. SEQUENCE may be a dotted list. +*/ + (sequence)) +{ + again: + if (NILP (sequence)) return sequence; + if (CONSP (sequence)) return copy_list (sequence); + if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); + if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); + if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); + + check_losing_bytecode ("copy-sequence", sequence); + sequence = wrong_type_argument (Qsequencep, sequence); goto again; } @@ -871,7 +885,6 @@ Relevant parts of the string-extent-data are copied in the new string. Lisp_Object val; CHECK_STRING (string); - /* Historically, FROM could not be omitted. Whatever ... */ CHECK_INT (from); get_string_range_char (string, from, to, &ccfr, &ccto, GB_HISTORICAL_STRING_BEHAVIOR); @@ -1023,9 +1036,9 @@ Return element of SEQUENCE at index N. args_out_of_range (sequence, n); #endif } - else if (STRINGP (sequence) - || VECTORP (sequence) - || BIT_VECTORP (sequence)) + else if (STRINGP (sequence) || + VECTORP (sequence) || + BIT_VECTORP (sequence)) return Faref (sequence, n); #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (sequence)) @@ -1038,24 +1051,24 @@ Return element of SEQUENCE at index N. } /* Utter perversity */ { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence); switch (idx) { case COMPILED_ARGLIST: - return b->arglist; - case COMPILED_BYTECODE: - return b->bytecodes; + return compiled_function_arglist (f); + case COMPILED_INSTRUCTIONS: + return compiled_function_instructions (f); case COMPILED_CONSTANTS: - return b->constants; + return compiled_function_constants (f); case COMPILED_STACK_DEPTH: - return make_int (b->maxdepth); + return compiled_function_stack_depth (f); case COMPILED_DOC_STRING: - return compiled_function_documentation (b); + return compiled_function_documentation (f); case COMPILED_DOMAIN: - return compiled_function_domain (b); + return compiled_function_domain (f); case COMPILED_INTERACTIVE: - if (b->flags.interactivep) - return compiled_function_interactive (b); + if (f->flags.interactivep) + return compiled_function_interactive (f); /* if we return nil, can't tell interactive with no args from noninteractive. */ goto lose; @@ -1073,19 +1086,126 @@ Return element of SEQUENCE at index N. } } +DEFUN ("last", Flast, 1, 2, 0, /* +Return the tail of list LIST, of length N (default 1). +LIST may be a dotted list, but not a circular list. +Optional argument N must be a non-negative integer. +If N is zero, then the atom that terminates the list is returned. +If N is greater than the length of LIST, then LIST itself is returned. +*/ + (list, n)) +{ + int int_n, count; + Lisp_Object retval, tortoise, hare; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + for (retval = tortoise = hare = list, count = 0; + CONSP (hare); + hare = XCDR (hare), + (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), + count++) + { + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (hare, tortoise)) + signal_circular_list_error (list); + } + + return retval; +} + +DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* +Modify LIST to remove the last N (default 1) elements. +If LIST has N or fewer elements, nil is returned and LIST is unmodified. +*/ + (list, n)) +{ + int int_n; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + { + Lisp_Object last_cons = list; + + EXTERNAL_LIST_LOOP_1 (list) + { + if (int_n-- < 0) + last_cons = XCDR (last_cons); + } + + if (int_n >= 0) + return Qnil; + + XCDR (last_cons) = Qnil; + return list; + } +} + +DEFUN ("butlast", Fbutlast, 1, 2, 0, /* +Return a copy of LIST with the last N (default 1) elements removed. +If LIST has N or fewer elements, nil is returned. +*/ + (list, n)) +{ + int int_n; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + { + Lisp_Object retval = Qnil; + Lisp_Object tail = list; + + EXTERNAL_LIST_LOOP_1 (list) + { + if (--int_n < 0) + { + retval = Fcons (XCAR (tail), retval); + tail = XCDR (tail); + } + } + + return Fnreverse (retval); + } +} + DEFUN ("member", Fmember, 2, 2, 0, /* 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. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - CONCHECK_CONS (tail); - if (internal_equal (elt, XCAR (tail), 0)) + if (internal_equal (elt, list_elt, 0)) return tail; - QUIT; } return Qnil; } @@ -1098,13 +1218,11 @@ Do not use it. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - CONCHECK_CONS (tail); - if (internal_old_equal (elt, XCAR (tail), 0)) + if (internal_old_equal (elt, list_elt, 0)) return tail; - QUIT; } return Qnil; } @@ -1115,14 +1233,11 @@ The value is actually the tail of LIST whose car is ELT. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) return tail; - QUIT; } return Qnil; } @@ -1135,14 +1250,11 @@ Do not use it. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem)) + if (HACKEQ_UNSAFE (elt, list_elt)) return tail; - QUIT; } return Qnil; } @@ -1150,11 +1262,10 @@ Do not use it. Lisp_Object memq_no_quit (Lisp_Object elt, Lisp_Object list) { - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object list_elt, tail; + LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) return tail; } return Qnil; @@ -1167,15 +1278,11 @@ The value is actually the element of LIST whose car equals KEY. (key, list)) { /* This function can GC. */ - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (XCAR (elt), key, 0)) + if (internal_equal (key, elt_car, 0)) return elt; - QUIT; } return Qnil; } @@ -1187,15 +1294,11 @@ The value is actually the element of LIST whose car equals KEY. (key, list)) { /* This function can GC. */ - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0)) + if (internal_old_equal (key, elt_car, 0)) return elt; - QUIT; } return Qnil; } @@ -1215,15 +1318,11 @@ Elements of LIST that are not conses are ignored. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) return elt; - QUIT; } return Qnil; } @@ -1237,15 +1336,11 @@ Do not use it. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem))) + if (HACKEQ_UNSAFE (key, elt_car)) return elt; - QUIT; } return Qnil; } @@ -1257,13 +1352,12 @@ Lisp_Object assq_no_quit (Lisp_Object key, Lisp_Object list) { /* This cannot GC. */ - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object elt; + LIST_LOOP_2 (elt, list) { - REGISTER Lisp_Object tem, elt; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - return elt; + Lisp_Object elt_car = XCAR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; } return Qnil; } @@ -1274,15 +1368,11 @@ The value is actually the element of LIST whose cdr equals KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (XCDR (elt), key, 0)) + if (internal_equal (key, elt_cdr, 0)) return elt; - QUIT; } return Qnil; } @@ -1293,15 +1383,11 @@ The value is actually the element of LIST whose cdr equals KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0)) + if (internal_old_equal (key, elt_cdr, 0)) return elt; - QUIT; } return Qnil; } @@ -1312,15 +1398,11 @@ The value is actually the element of LIST whose cdr is KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) return elt; - QUIT; } return Qnil; } @@ -1331,28 +1413,25 @@ The value is actually the element of LIST whose cdr is KEY. */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem))) + if (HACKEQ_UNSAFE (key, elt_cdr)) return elt; - QUIT; } return Qnil; } +/* Like Frassq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ Lisp_Object rassq_no_quit (Lisp_Object key, Lisp_Object list) { - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object elt; + LIST_LOOP_2 (elt, list) { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + Lisp_Object elt_cdr = XCDR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) return elt; } return Qnil; @@ -1369,24 +1448,9 @@ Also see: `remove'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - CONCHECK_CONS (tail); - if (internal_equal (elt, XCAR (tail), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_equal (elt, list_elt, 0))); return list; } @@ -1399,24 +1463,9 @@ of changing the value of `foo'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - CONCHECK_CONS (tail); - if (internal_old_equal (elt, XCAR (tail), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_old_equal (elt, list_elt, 0))); return list; } @@ -1429,25 +1478,9 @@ changing the value of `foo'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; } @@ -1460,50 +1493,21 @@ changing the value of `foo'. */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (HACKEQ_UNSAFE (elt, list_elt))); return list; } -/* no quit, no errors; be careful */ +/* Like Fdelq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ Lisp_Object delq_no_quit (Lisp_Object elt, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object list_elt; + LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; } @@ -1519,26 +1523,24 @@ delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) { REGISTER Lisp_Object tail = list; REGISTER Lisp_Object prev = Qnil; - struct Lisp_Cons *cons_to_free = NULL; - while (CONSP (tail)) + while (!NILP (tail)) { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + REGISTER Lisp_Object tem = XCAR (tail); + if (EQ (elt, tem)) { + Lisp_Object cons_to_free = tail; if (NILP (prev)) list = XCDR (tail); else XCDR (prev) = XCDR (tail); - cons_to_free = XCONS (tail); + tail = XCDR (tail); + free_cons (XCONS (cons_to_free)); } else - prev = tail; - tail = XCDR (tail); - if (cons_to_free) { - free_cons (cons_to_free); - cons_to_free = NULL; + prev = tail; + tail = XCDR (tail); } } return list; @@ -1553,26 +1555,10 @@ the value of `foo'. */ (key, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (key, XCAR (elt), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + internal_equal (key, XCAR (elt), 0))); return list; } @@ -1593,26 +1579,10 @@ the value of `foo'. */ (key, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); return list; } @@ -1621,24 +1591,10 @@ the value of `foo'. Lisp_Object remassq_no_quit (Lisp_Object key, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object elt; + LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); return list; } @@ -1651,26 +1607,10 @@ the value of `foo'. */ (value, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (value, XCDR (elt), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + internal_equal (value, XCDR (elt), 0))); return list; } @@ -1683,52 +1623,21 @@ the value of `foo'. */ (value, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); return list; } -/* no quit, no errors; be careful */ - +/* Like Fremrassq, fast and unsafe; be careful */ Lisp_Object remrassq_no_quit (Lisp_Object value, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object elt; + LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); return list; } @@ -1748,7 +1657,6 @@ Also see: `reverse'. while (!NILP (tail)) { REGISTER Lisp_Object next; - QUIT; CONCHECK_CONS (tail); next = XCDR (tail); XCDR (tail) = prev; @@ -1765,17 +1673,13 @@ See also the function `nreverse', which is used more often. */ (list)) { - REGISTER Lisp_Object tail; - Lisp_Object new = Qnil; - - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object reversed_list = Qnil; + Lisp_Object elt; + EXTERNAL_LIST_LOOP_2 (elt, list) { - new = Fcons (XCAR (tail), new); - QUIT; + reversed_list = Fcons (elt, reversed_list); } - if (!NILP (tail)) - dead_wrong_type_argument (Qlistp, tail); - return new; + return reversed_list; } static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, @@ -2081,13 +1985,12 @@ If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with Lisp_Object internal_plist_get (Lisp_Object plist, Lisp_Object property) { - Lisp_Object tail = plist; + Lisp_Object tail; - for (; !NILP (tail); tail = XCDR (XCDR (tail))) + for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) { - struct Lisp_Cons *c = XCONS (tail); - if (EQ (c->car, property)) - return XCAR (c->cdr); + if (EQ (XCAR (tail), property)) + return XCAR (XCDR (tail)); } return Qunbound; @@ -2117,26 +2020,22 @@ internal_plist_put (Lisp_Object *plist, Lisp_Object property, int internal_remprop (Lisp_Object *plist, Lisp_Object property) { - Lisp_Object tail = *plist; - - if (NILP (tail)) - return 0; - - if (EQ (XCAR (tail), property)) - { - *plist = XCDR (XCDR (tail)); - return 1; - } + Lisp_Object tail, prev; - for (tail = XCDR (tail); !NILP (XCDR (tail)); + for (tail = *plist, prev = Qnil; + !NILP (tail); tail = XCDR (XCDR (tail))) { - struct Lisp_Cons *c = XCONS (tail); - if (EQ (XCAR (c->cdr), property)) + if (EQ (XCAR (tail), property)) { - c->cdr = XCDR (XCDR (c->cdr)); + if (NILP (prev)) + *plist = XCDR (XCDR (tail)); + else + XCDR (XCDR (prev)) = XCDR (XCDR (tail)); return 1; } + else + prev = tail; } return 0; @@ -2211,7 +2110,7 @@ advance_plist_pointers (Lisp_Object *plist, Lisp_Object *tortsave = *tortoise; /* Note that our "fixing" may be more brutal than necessary, - but it's the user's own problem, not ours. if they went in and + but it's the user's own problem, not ours, if they went in and manually fucked up a plist. */ for (i = 0; i < 2; i++) @@ -2385,9 +2284,7 @@ one of the properties on the list. (plist, prop, default_)) { Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME); - if (UNBOUNDP (val)) - return default_; - return val; + return UNBOUNDP (val) ? default_ : val; } DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* @@ -2423,7 +2320,8 @@ Return t if PROP has a value specified in PLIST. */ (plist, prop)) { - return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? Qnil : Qt; + Lisp_Object val = Fplist_get (plist, prop, Qunbound); + return UNBOUNDP (val) ? Qnil : Qt; } DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* @@ -2512,7 +2410,8 @@ The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the /* external_remprop returns 1 if it removed any property. We have to loop till it didn't remove anything, in case the property occurs many times. */ - while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)); + while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) + DO_NOTHING; plist = Fcdr (next); } @@ -2523,7 +2422,7 @@ DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* Extract a value from a lax property list. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. This function returns the value corresponding to the given PROP, or DEFAULT if PROP is not one of the properties on the list. @@ -2539,7 +2438,7 @@ properties on the list. DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* Change value in LAX-PLIST of PROP to VAL. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. PROP is usually a symbol and VAL is any object. If PROP is already a property on the list, its value is set to VAL, otherwise the new PROP VAL pair is added. The new plist @@ -2555,7 +2454,7 @@ use the new value. The LAX-PLIST is modified by side effects. DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* Remove from LAX-PLIST the property PROP and its value. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. PROP is usually a symbol. The new plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be sure to use the new value. The LAX-PLIST is modified by side effects. @@ -2569,7 +2468,7 @@ sure to use the new value. The LAX-PLIST is modified by side effects. DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* Return t if PROP has a value specified in LAX-PLIST. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. */ (lax_plist, prop)) @@ -2612,7 +2511,8 @@ The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the /* external_remprop returns 1 if it removed any property. We have to loop till it didn't remove anything, in case the property occurs many times. */ - while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)); + while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) + DO_NOTHING; lax_plist = Fcdr (next); } @@ -2733,37 +2633,35 @@ or string. See also `put', `remprop', and `object-plist'. */ (object, propname, default_)) { - Lisp_Object val; - /* Various places in emacs call Fget() and expect it not to quit, so don't quit. */ /* It's easiest to treat symbols specially because they may not be an lrecord */ if (SYMBOLP (object)) - val = symbol_getprop (object, propname, default_); + return symbol_getprop (object, propname, default_); else if (STRINGP (object)) - val = string_getprop (XSTRING (object), propname, default_); + return string_getprop (XSTRING (object), propname, default_); else if (LRECORDP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->getprop) - { - val = (imp->getprop) (object, propname); - if (UNBOUNDP (val)) - val = default_; - } - else + CONST struct lrecord_implementation *imp + = XRECORD_LHEADER_IMPLEMENTATION (object); + if (!imp->getprop) goto noprops; + + { + Lisp_Object val = (imp->getprop) (object, propname); + if (UNBOUNDP (val)) + val = default_; + return val; + } } else { noprops: signal_simple_error ("Object type has no properties", object); + return Qnil; /* Not reached */ } - - return val; } DEFUN ("put", Fput, 3, 3, 0, /* @@ -2884,7 +2782,7 @@ interpretation, this will probably have no effect at all.) int -internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) +internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); @@ -2892,28 +2790,28 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) do_cdr: #endif QUIT; - if (EQ_WITH_EBOLA_NOTICE (o1, o2)) + if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ - else if (XTYPE (o1) != XTYPE (o2)) + if (XTYPE (obj1) != XTYPE (obj2)) return 0; #ifndef LRECORD_CONS - else if (CONSP (o1)) + if (CONSP (obj1)) { - if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1)) + if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1)) return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); + obj1 = XCDR (obj1); + obj2 = XCDR (obj2); goto do_cdr; } #endif #ifndef LRECORD_VECTOR - else if (VECTORP (o1)) + if (VECTORP (obj1)) { - Lisp_Object *v1 = XVECTOR_DATA (o1); - Lisp_Object *v2 = XVECTOR_DATA (o2); - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) + Lisp_Object *v1 = XVECTOR_DATA (obj1); + Lisp_Object *v2 = XVECTOR_DATA (obj2); + int len = XVECTOR_LENGTH (obj1); + if (len != XVECTOR_LENGTH (obj2)) return 0; while (len--) if (!internal_equal (*v1++, *v2++, depth + 1)) @@ -2922,25 +2820,22 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) } #endif #ifndef LRECORD_STRING - else if (STRINGP (o1)) + if (STRINGP (obj1)) { Bytecount len; - return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) && - !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)); + return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && + !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); } #endif - else if (LRECORDP (o1)) + if (LRECORDP (obj1)) { CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1), - *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2); - if (imp1 != imp2) - return 0; - else if (imp1->equal == 0) + *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), + *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); + + return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - return 0; - else - return (imp1->equal) (o1, o2, depth); + (imp1->equal && (imp1->equal) (obj1, obj2, depth)); } return 0; @@ -2952,7 +2847,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) but that seems unlikely. */ static int -internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth) +internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); @@ -2960,64 +2855,37 @@ internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth) do_cdr: #endif QUIT; - if (HACKEQ_UNSAFE (o1, o2)) + if (HACKEQ_UNSAFE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ - else if (XTYPE (o1) != XTYPE (o2)) + if (XTYPE (obj1) != XTYPE (obj2)) return 0; #ifndef LRECORD_CONS - else if (CONSP (o1)) + if (CONSP (obj1)) { - if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1)) + if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1)) return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); + obj1 = XCDR (obj1); + obj2 = XCDR (obj2); goto do_cdr; } #endif #ifndef LRECORD_VECTOR - else if (VECTORP (o1)) + if (VECTORP (obj1)) { - int indice; - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) - return 0; - for (indice = 0; indice < len; indice++) - { - if (!internal_old_equal (XVECTOR_DATA (o1) [indice], - XVECTOR_DATA (o2) [indice], - depth + 1)) - return 0; - } - return 1; - } -#endif -#ifndef LRECORD_STRING - else if (STRINGP (o1)) - { - Bytecount len = XSTRING_LENGTH (o1); - if (len != XSTRING_LENGTH (o2)) - return 0; - if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)) + Lisp_Object *v1 = XVECTOR_DATA (obj1); + Lisp_Object *v2 = XVECTOR_DATA (obj2); + int len = XVECTOR_LENGTH (obj1); + if (len != XVECTOR_LENGTH (obj2)) return 0; + while (len--) + if (!internal_old_equal (*v1++, *v2++, depth + 1)) + return 0; return 1; } #endif - else if (LRECORDP (o1)) - { - CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1), - *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2); - if (imp1 != imp2) - return 0; - else if (imp1->equal == 0) - /* EQ-ness of the objects was noticed above */ - return 0; - else - return (imp1->equal) (o1, o2, depth); - } - return 0; + return internal_equal (obj1, obj2, depth); } DEFUN ("equal", Fequal, 2, 2, 0, /* @@ -3027,9 +2895,9 @@ Conses are compared by comparing the cars and the cdrs. Vectors and strings are compared element by element. Numbers are compared by value. Symbols must match exactly. */ - (o1, o2)) + (obj1, obj2)) { - return internal_equal (o1, o2, 0) ? Qt : Qnil; + return internal_equal (obj1, obj2, 0) ? Qt : Qnil; } DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* @@ -3041,9 +2909,9 @@ this is known as the "char-int confoundance disease." See `eq' and This function is provided only for byte-code compatibility with v19. Do not use it. */ - (o1, o2)) + (obj1, obj2)) { - return internal_old_equal (o1, o2, 0) ? Qt : Qnil; + return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil; } @@ -3095,12 +2963,53 @@ ARRAY is a vector, bit vector, or string. } Lisp_Object -nconc2 (Lisp_Object s1, Lisp_Object s2) +nconc2 (Lisp_Object arg1, Lisp_Object arg2) { Lisp_Object args[2]; - args[0] = s1; - args[1] = s2; - return Fnconc (2, args); + struct gcpro gcpro1; + args[0] = arg1; + args[1] = arg2; + + GCPRO1 (args[0]); + gcpro1.nvars = 2; + + RETURN_UNGCPRO (bytecode_nconc2 (args)); +} + +Lisp_Object +bytecode_nconc2 (Lisp_Object *args) +{ + retry: + + if (CONSP (args[0])) + { + /* (setcdr (last args[0]) args[1]) */ + Lisp_Object tortoise, hare; + int count; + + for (hare = tortoise = args[0], count = 0; + CONSP (XCDR (hare)); + hare = XCDR (hare), count++) + { + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (hare, tortoise)) + signal_circular_list_error (args[0]); + } + XCDR (hare) = args[1]; + return args[0]; + } + else if (NILP (args[0])) + { + return args[1]; + } + else + { + args[0] = wrong_type_argument (args[0], Qlistp); + goto retry; + } } DEFUN ("nconc", Fnconc, 0, MANY, 0, /* @@ -3131,22 +3040,32 @@ changing the value of `foo'. Lisp_Object val = args[argnum]; if (CONSP (val)) { - /* Found the first cons, which will be our return value. */ - Lisp_Object last = val; + /* `val' is the first cons, which will be our return value. */ + /* `last_cons' will be the cons cell to mutate. */ + Lisp_Object last_cons = val; + Lisp_Object tortoise = val; for (argnum++; argnum < nargs; argnum++) { Lisp_Object next = args[argnum]; - redo: + retry: if (CONSP (next) || argnum == nargs -1) { /* (setcdr (last val) next) */ - while (CONSP (XCDR (last))) + int count; + + for (count = 0; + CONSP (XCDR (last_cons)); + last_cons = XCDR (last_cons), count++) { - last = XCDR (last); - QUIT; + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (last_cons, tortoise)) + signal_circular_list_error (args[argnum-1]); } - XCDR (last) = next; + XCDR (last_cons) = next; } else if (NILP (next)) { @@ -3155,7 +3074,7 @@ changing the value of `foo'. else { next = wrong_type_argument (next, Qlistp); - goto redo; + goto retry; } } RETURN_UNGCPRO (val); @@ -3771,20 +3690,20 @@ free_malloced_ptr (Lisp_Object unwind_obj) ways these functions can blow up, and we don't want to have memory leaks in those cases. */ #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \ - if ((len) > MAX_ALLOCA) \ + size_t XOA_len = (len); \ + if (XOA_len > MAX_ALLOCA) \ { \ - ptr = (type *)xmalloc ((len) * sizeof (type)); \ - speccount = specpdl_depth (); \ + ptr = xnew_array (type, XOA_len); \ record_unwind_protect (free_malloced_ptr, \ make_opaque_ptr ((void *)ptr)); \ } \ else \ - ptr = alloca_array (type, len); \ + ptr = alloca_array (type, XOA_len); \ } while (0) -#define XMALLOC_UNBIND(ptr, len) do { \ - if ((len) > MAX_ALLOCA) \ - unbind_to (speccount, Qnil); \ +#define XMALLOC_UNBIND(ptr, len, speccount) do { \ + if ((len) > MAX_ALLOCA) \ + unbind_to (speccount, Qnil); \ } while (0) DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* @@ -3801,9 +3720,10 @@ into shorter lines. struct buffer *buf = current_buffer; Bufpos begv, zv, old_pt = BUF_PT (buf); Lisp_Object input; - int speccount; + int speccount = specpdl_depth(); get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + barf_if_buffer_read_only (buf, begv, zv); /* We need to allocate enough room for encoding the text. We need 33 1/3% more space, plus a newline every 76 @@ -3825,7 +3745,7 @@ 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.) */ buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); - XMALLOC_UNBIND (encoded, allength); + XMALLOC_UNBIND (encoded, allength, speccount); buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); /* Simulate FSF Emacs: if point was in the region, place it at the @@ -3846,7 +3766,7 @@ Base64 encode STRING and return the result. Bytind encoded_length; Bufbyte *encoded; Lisp_Object input, result; - int speccount; + int speccount = specpdl_depth(); CHECK_STRING (string); @@ -3860,7 +3780,7 @@ Base64 encode STRING and return the result. abort (); Lstream_delete (XLSTREAM (input)); result = make_string (encoded, encoded_length); - XMALLOC_UNBIND (encoded, allength); + XMALLOC_UNBIND (encoded, allength, speccount); return result; } @@ -3877,9 +3797,11 @@ If the region can't be decoded, return nil and don't modify the buffer. Bytind decoded_length; Charcount length, cc_decoded_length; Lisp_Object input; - int speccount; + int speccount = specpdl_depth(); get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + barf_if_buffer_read_only (buf, begv, zv); + length = zv - begv; input = make_lisp_buffer_input_stream (buf, begv, zv, 0); @@ -3893,7 +3815,7 @@ If the region can't be decoded, return nil and don't modify the buffer. if (decoded_length < 0) { /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return Qnil; } @@ -3901,7 +3823,7 @@ If the region can't be decoded, return nil and don't modify the buffer. and delete the old. (Insert first in order to preserve markers.) */ BUF_SET_PT (buf, begv); buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); buffer_delete_range (buf, begv + cc_decoded_length, zv + cc_decoded_length, 0); @@ -3922,7 +3844,7 @@ Base64-decode STRING and return the result. Bytind decoded_length; Charcount length, cc_decoded_length; Lisp_Object input, result; - int speccount; + int speccount = specpdl_depth(); CHECK_STRING (string); @@ -3939,12 +3861,13 @@ Base64-decode STRING and return the result. if (decoded_length < 0) { + /* The decoding wasn't possible. */ + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return Qnil; - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); } result = make_string (decoded, decoded_length); - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return result; } @@ -3968,6 +3891,7 @@ syms_of_fns (void) DEFSUBR (Fconcat); DEFSUBR (Fvconcat); DEFSUBR (Fbvconcat); + DEFSUBR (Fcopy_list); DEFSUBR (Fcopy_sequence); DEFSUBR (Fcopy_alist); DEFSUBR (Fcopy_tree); @@ -3976,6 +3900,9 @@ syms_of_fns (void) DEFSUBR (Fnthcdr); DEFSUBR (Fnth); DEFSUBR (Felt); + DEFSUBR (Flast); + DEFSUBR (Fbutlast); + DEFSUBR (Fnbutlast); DEFSUBR (Fmember); DEFSUBR (Fold_member); DEFSUBR (Fmemq); diff --git a/src/frame-msw.c b/src/frame-msw.c index f7d154a..2b2b10c 100644 --- a/src/frame-msw.c +++ b/src/frame-msw.c @@ -126,9 +126,9 @@ mswindows_init_frame_1 (struct frame *f, Lisp_Object props) FRAME_MSWINDOWS_DATA(f)->ignore_next_lbutton_up = 0; FRAME_MSWINDOWS_DATA(f)->ignore_next_rbutton_up = 0; FRAME_MSWINDOWS_DATA(f)->sizing = 0; - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil; #ifdef HAVE_TOOLBARS - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE(f) = Fmake_hashtable (make_int (50), + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f) = Fmake_hash_table (make_int (50), Qequal); #endif @@ -234,8 +234,8 @@ mswindows_after_init_frame (struct frame *f, int first_on_device, frame is created, it will never be displayed, except for hollow border, unless we start pumping messages. Load progress messages show in the bottom of the hollow frame, which is ugly. - We redipsplay the initial frame here, so modeline and root window - backgorund show. + We redisplay the initial frame here, so modeline and root window + background show. */ if (first_on_console) redisplay (); @@ -244,9 +244,9 @@ mswindows_after_init_frame (struct frame *f, int first_on_device, static void mswindows_mark_frame (struct frame *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FRAME_MSWINDOWS_MENU_HASHTABLE (f))); + markobj (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); #ifdef HAVE_TOOLBARS - ((markobj) (FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f))); + markobj (FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f)); #endif } @@ -322,7 +322,7 @@ mswindows_frame_totally_visible_p (struct frame *f) RECT rc_me, rc_other, rc_temp; HWND hwnd = FRAME_MSWINDOWS_HANDLE(f); - /* We test against not a whole window rectangle, only agaist its + /* We test against not a whole window rectangle, only against its client part. So, if non-client are is covered and client area is not, we return true. */ GetClientRect (hwnd, &rc_me); diff --git a/src/frame-tty.c b/src/frame-tty.c index 24438e7..a079f8a 100644 --- a/src/frame-tty.c +++ b/src/frame-tty.c @@ -155,13 +155,11 @@ tty_frame_visible_p (struct frame *f) static void tty_raise_frame_no_select (struct frame *f) { - struct frame *o; - Lisp_Object tail; - - LIST_LOOP (tail, DEVICE_FRAME_LIST (XDEVICE (FRAME_DEVICE (f)))) + Lisp_Object frame; + LIST_LOOP_2 (frame, DEVICE_FRAME_LIST (XDEVICE (FRAME_DEVICE (f)))) { - o = XFRAME (XCAR (tail)); - if (o != f && FRAME_REPAINT_P(o)) + struct frame *o = XFRAME (frame); + if (o != f && FRAME_REPAINT_P (o)) { tty_make_frame_hidden (o); break; @@ -216,7 +214,7 @@ tty_delete_frame (struct frame *f) } /************************************************************************/ -/* initialization */ +/* initialization */ /************************************************************************/ void diff --git a/src/frame-x.c b/src/frame-x.c index 76acd22..4011bdb 100644 --- a/src/frame-x.c +++ b/src/frame-x.c @@ -278,8 +278,7 @@ x_wm_hack_wm_protocols (Widget widget) int need_delete = 1; int need_focus = 1; - if (!XtIsWMShell (widget)) - abort (); + assert (XtIsWMShell (widget)); { Atom type, *atoms = 0; @@ -996,7 +995,7 @@ x_cde_destroy_callback (Widget widget, XtPointer clientData, { for (i = 0; i < dragData->numItems; i++) { - XtFree(dragData->data.buffers[i].bp); + XtFree((char *) dragData->data.buffers[i].bp); if (dragData->data.buffers[i].name) XtFree(dragData->data.buffers[i].name); } @@ -1151,7 +1150,7 @@ WARNING: can only handle plain/text and file: transfers! numItems++; item = XCDR (item); } - + if (numItems) { /* @@ -1160,7 +1159,7 @@ WARNING: can only handle plain/text and file: transfers! */ Ctext = (char *)xmalloc (textlen+1); Ctext[0] = 0; - + item = dragdata; while (!NILP (item)) { @@ -1176,12 +1175,12 @@ WARNING: can only handle plain/text and file: transfers! item = XCDR (item); } Ctext[pos] = 0; - + dnd_convert_cb_rec[0].callback = x_cde_convert_callback; dnd_convert_cb_rec[0].closure = (XtPointer) Ctext; dnd_convert_cb_rec[1].callback = NULL; dnd_convert_cb_rec[1].closure = NULL; - + dnd_destroy_cb_rec[0].callback = x_cde_destroy_callback; dnd_destroy_cb_rec[0].closure = (XtPointer) Ctext; dnd_destroy_cb_rec[1].callback = NULL; @@ -1198,7 +1197,7 @@ WARNING: can only handle plain/text and file: transfers! } UNGCPRO; - + return numItems?Qt:Qnil; } @@ -1268,7 +1267,7 @@ x_cde_transfer_callback (Widget widget, XtPointer clientData, /* what, if the data is no text, and how can I tell it? */ l_data = Fcons ( list3 ( list1 ( make_string ((Bufbyte *)"text/plain", 10) ), make_string ((Bufbyte *)"8bit", 4), - make_string ((Bufbyte *)transferInfo->dropData->data.buffers[ii].bp, + make_string ((Bufbyte *)transferInfo->dropData->data.buffers[ii].bp, transferInfo->dropData->data.buffers[ii].size) ), l_data ); } @@ -1279,7 +1278,7 @@ x_cde_transfer_callback (Widget widget, XtPointer clientData, enqueue=0; /* The Problem: no button and mods from CDE... */ - if (enqueue) + if (enqueue) enqueue_misc_user_event_pos ( frame, Qdragdrop_drop_dispatch, Fcons (l_type, l_data), 0 /* this is the button */, @@ -1361,15 +1360,13 @@ The type defaults to DndText (4). if (!STRINGP (data)) return Qnil; - /* and whats with MULE data ??? */ + /* and what's with MULE data ??? */ dnd_data = (char *)XSTRING_DATA (data); dnd_len = XSTRING_LENGTH (data) + 1; /* the zero */ } - /* - * not so cross hack that converts a emacs event back to a XEvent - */ + /* not so gross hack that converts an emacs event back to a XEvent */ x_event.xbutton.type = ButtonPress; x_event.xbutton.send_event = False; @@ -1923,9 +1920,9 @@ x_create_widgets (struct frame *f, Lisp_Object lisp_window_id, XtSetArg (al[ac], XtNinput, True); ac++; XtSetArg (al[ac], XtNminWidthCells, 10); ac++; XtSetArg (al[ac], XtNminHeightCells, 1); ac++; - XtSetArg (al[ac], XtNvisual, visual); ac++; - XtSetArg (al[ac], XtNdepth, depth); ac++; - XtSetArg (al[ac], XtNcolormap, cmap); ac++; + XtSetArg (al[ac], XtNvisual, visual); ac++; + XtSetArg (al[ac], XtNdepth, depth); ac++; + XtSetArg (al[ac], XtNcolormap, cmap); ac++; } if (!NILP (parent)) @@ -1995,7 +1992,7 @@ x_create_widgets (struct frame *f, Lisp_Object lisp_window_id, though, the failure to call the popup callbacks resulted in XEmacs not accepting any input. Bizarre but true. Stupid but true. - So, in case there are any other gotches floating out there along + So, in case there are any other gotchas floating out there along the same lines I've duplicated the majority of XtPopup here. It assumes no grabs and that the widget is not already popped up, both valid assumptions for the one place this is called from. */ @@ -2021,12 +2018,6 @@ xemacs_XtPopup (Widget widget) Xt_SET_VALUE (widget, XtNmappedWhenManaged, True); } -#ifdef HAVE_CDE -/* Does this have to be non-automatic? */ -/* hack frame to respond to dnd messages */ -static XtCallbackRec dnd_transfer_cb_rec[2]; -#endif /* HAVE_CDE */ - /* create the windows for the specified frame and display them. Note that the widgets have already been created, and any necessary geometry calculations have already been done. */ @@ -2081,7 +2072,7 @@ x_popup_frame (struct frame *f) #ifdef HACK_EDITRES /* Allow XEmacs to respond to EditRes requests. See the O'Reilly Xt */ - /* Instrinsics Programming Manual, Motif Edition, Aug 1993, Sect 14.14, */ + /* Intrinsics Programming Manual, Motif Edition, Aug 1993, Sect 14.14, */ /* pp. 483-493. */ XtAddEventHandler (shell_widget, /* the shell widget in question */ (EventMask) NoEventMask,/* OR with existing mask */ @@ -2092,6 +2083,8 @@ x_popup_frame (struct frame *f) #ifdef HAVE_CDE { + XtCallbackRec dnd_transfer_cb_rec[2]; + dnd_transfer_cb_rec[0].callback = x_cde_transfer_callback; dnd_transfer_cb_rec[0].closure = (XtPointer) f; dnd_transfer_cb_rec[1].callback = NULL; @@ -2101,7 +2094,7 @@ x_popup_frame (struct frame *f) DtDND_FILENAME_TRANSFER | DtDND_BUFFER_TRANSFER, XmDROP_COPY, dnd_transfer_cb_rec, DtNtextIsBuffer, True, - DtNregisterChildren, True, + DtNregisterChildren, True, DtNpreserveRegistration, False, NULL); } @@ -2183,9 +2176,9 @@ x_init_frame_2 (struct frame *f, Lisp_Object props) * will update the frame title anyway, so nothing is lost. * JV: * It turns out it gives problems with FVWMs name based mapping. - * We'll just need to be carefull in the modeline specs. + * We'll just need to be careful in the modeline specs. */ - update_frame_title (f); + update_frame_title (f); } static void @@ -2199,8 +2192,8 @@ x_init_frame_3 (struct frame *f) static void x_mark_frame (struct frame *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FRAME_X_ICON_PIXMAP (f))); - ((markobj) (FRAME_X_ICON_PIXMAP_MASK (f))); + markobj (FRAME_X_ICON_PIXMAP (f)); + markobj (FRAME_X_ICON_PIXMAP_MASK (f)); } static void @@ -2630,40 +2623,54 @@ x_focus_on_frame (struct frame *f) static void x_delete_frame (struct frame *f) { - Widget w = FRAME_X_SHELL_WIDGET (f); - Display *dpy = XtDisplay (w); - #ifndef HAVE_SESSION if (FRAME_X_TOP_LEVEL_FRAME_P (f)) x_wm_maybe_move_wm_command (f); #endif /* HAVE_SESSION */ -#ifdef EXTERNAL_WIDGET - expect_x_error (dpy); - /* for obscure reasons having (I think) to do with the internal - window-to-widget hierarchy maintained by Xt, we have to call - XtUnrealizeWidget() here. Xt can really suck. */ - if (f->being_deleted) - XtUnrealizeWidget (w); - XtDestroyWidget (w); - x_error_occurred_p (dpy); -#else - XtDestroyWidget (w); - XFlush (dpy); /* make sure the windows are really gone! */ -#endif /* EXTERNAL_WIDGET */ +#ifdef HAVE_CDE + DtDndDropUnregister (FRAME_X_TEXT_WIDGET (f)); +#endif /* HAVE_CDE */ + + assert (FRAME_X_SHELL_WIDGET (f)); + if (FRAME_X_SHELL_WIDGET (f)) + { + Display *dpy = XtDisplay (FRAME_X_SHELL_WIDGET (f)); + expect_x_error (dpy); + /* for obscure reasons having (I think) to do with the internal + window-to-widget hierarchy maintained by Xt, we have to call + XtUnrealizeWidget() here. Xt can really suck. */ + if (f->being_deleted) + XtUnrealizeWidget (FRAME_X_SHELL_WIDGET (f)); + XtDestroyWidget (FRAME_X_SHELL_WIDGET (f)); + x_error_occurred_p (dpy); + + /* make sure the windows are really gone! */ + /* ### Is this REALLY necessary? */ + XFlush (dpy); + + FRAME_X_SHELL_WIDGET (f) = 0; + } if (FRAME_X_GEOM_FREE_ME_PLEASE (f)) - xfree (FRAME_X_GEOM_FREE_ME_PLEASE (f)); - xfree (f->frame_data); - f->frame_data = 0; + { + xfree (FRAME_X_GEOM_FREE_ME_PLEASE (f)); + FRAME_X_GEOM_FREE_ME_PLEASE (f) = 0; + } + + if (f->frame_data) + { + xfree (f->frame_data); + f->frame_data = 0; + } } static void x_update_frame_external_traits (struct frame* frm, Lisp_Object name) { - Arg av[10]; + Arg al[10]; int ac = 0; - Lisp_Object frame = Qnil; + Lisp_Object frame; XSETFRAME(frame, frm); @@ -2675,7 +2682,7 @@ x_update_frame_external_traits (struct frame* frm, Lisp_Object name) if (!EQ (color, Vthe_null_color_instance)) { fgc = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (color)); - XtSetArg (av[ac], XtNforeground, (void *) fgc.pixel); ac++; + XtSetArg (al[ac], XtNforeground, (void *) fgc.pixel); ac++; } } else if (EQ (name, Qbackground)) @@ -2686,7 +2693,7 @@ x_update_frame_external_traits (struct frame* frm, Lisp_Object name) if (!EQ (color, Vthe_null_color_instance)) { bgc = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (color)); - XtSetArg (av[ac], XtNbackground, (void *) bgc.pixel); ac++; + XtSetArg (al[ac], XtNbackground, (void *) bgc.pixel); ac++; } /* Really crappy way to force the modeline shadows to be @@ -2699,14 +2706,14 @@ x_update_frame_external_traits (struct frame* frm, Lisp_Object name) Lisp_Object font = FACE_FONT (Vdefault_face, frame, Vcharset_ascii); if (!EQ (font, Vthe_null_font_instance)) - XtSetArg (av[ac], XtNfont, + XtSetArg (al[ac], XtNfont, (void *) FONT_INSTANCE_X_FONT (XFONT_INSTANCE (font))); ac++; } else abort (); - XtSetValues (FRAME_X_TEXT_WIDGET (frm), av, ac); + XtSetValues (FRAME_X_TEXT_WIDGET (frm), al, ac); #ifdef HAVE_TOOLBARS /* Setting the background clears the entire frame area diff --git a/src/frame.c b/src/frame.c index 5891e24..38c8cc3 100644 --- a/src/frame.c +++ b/src/frame.c @@ -39,9 +39,6 @@ Boston, MA 02111-1307, USA. */ #include "scrollbar.h" #include "window.h" -#include -#include "sysdep.h" - Lisp_Object Vselect_frame_hook, Qselect_frame_hook; Lisp_Object Vdeselect_frame_hook, Qdeselect_frame_hook; Lisp_Object Vcreate_frame_hook, Qcreate_frame_hook; @@ -128,7 +125,7 @@ mark_frame (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct frame *f = XFRAME (obj); -#define MARKED_SLOT(x) ((markobj) (f->x)); +#define MARKED_SLOT(x) ((void) (markobj (f->x))); #include "frameslots.h" if (FRAME_LIVE_P (f)) /* device is nil for a dead frame */ @@ -190,10 +187,10 @@ allocate_frame_core (Lisp_Object device) XWINDOW (root_window)->frame = frame; /* 10 is arbitrary, - just so that there is "something there." + Just so that there is "something there." Correct size will be set up later with change_frame_size. */ - f->width = 10; + f->width = 10; f->height = 10; XWINDOW (root_window)->pixel_width = 10; @@ -580,7 +577,7 @@ unhold_frame_size_changes (void) void invalidate_vertical_divider_cache_in_frame (struct frame *f) { - /* Invalidate cached value of needs_vertical_divider_p in + /* Invalidate cached value of needs_vertical_divider_p in every and all windows */ map_windows (f, invalidate_vertical_divider_cache_in_window, 0); } @@ -892,7 +889,7 @@ set_frame_selected_window (struct frame *f, Lisp_Object window) #ifdef HAVE_TOOLBARS if (!EQ (f->last_nonminibuf_window, window)) MARK_TOOLBAR_CHANGED; -#endif +#endif f->last_nonminibuf_window = window; } } @@ -2795,7 +2792,7 @@ change_frame_size_1 (struct frame *f, int newheight, int newwidth) /* when frame_conversion_internal() calculated the number of rows/cols in the frame, the theoretical toolbar sizes were subtracted out. - The caluclations below adjust for real toolbar height/width in + The calculations below adjust for real toolbar height/width in frame, which may be different from frame spec, taking the above fact into account */ new_pixheight += @@ -2803,7 +2800,7 @@ change_frame_size_1 (struct frame *f, int newheight, int newwidth) + 2 * FRAME_THEORETICAL_TOP_TOOLBAR_BORDER_WIDTH (f) - FRAME_REAL_TOP_TOOLBAR_HEIGHT (f) - 2 * FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f); - + new_pixheight += + FRAME_THEORETICAL_BOTTOM_TOOLBAR_HEIGHT (f) + 2 * FRAME_THEORETICAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f) @@ -2815,13 +2812,13 @@ change_frame_size_1 (struct frame *f, int newheight, int newwidth) + 2 * FRAME_THEORETICAL_LEFT_TOOLBAR_BORDER_WIDTH (f) - FRAME_REAL_LEFT_TOOLBAR_WIDTH (f) - 2 * FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH (f); - + new_pixwidth += + FRAME_THEORETICAL_RIGHT_TOOLBAR_WIDTH (f) + 2 * FRAME_THEORETICAL_RIGHT_TOOLBAR_BORDER_WIDTH (f) - FRAME_REAL_RIGHT_TOOLBAR_WIDTH (f) - 2 * FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH (f); - + /* Adjust the width for the end glyph which may be a different width than the default character width. */ { @@ -2907,7 +2904,7 @@ change_frame_size_1 (struct frame *f, int newheight, int newwidth) FRAME_CHARWIDTH (f) = FRAME_WIDTH (f); FRAME_CHARHEIGHT (f) = FRAME_HEIGHT (f); } - + MARK_FRAME_TOOLBARS_CHANGED (f); MARK_FRAME_CHANGED (f); f->echo_area_garbaged = 1; diff --git a/src/frame.h b/src/frame.h index 3af2ae4..17ac712 100644 --- a/src/frame.h +++ b/src/frame.h @@ -23,8 +23,14 @@ Boston, MA 02111-1307, USA. */ #ifndef _XEMACS_FRAME_H_ #define _XEMACS_FRAME_H_ +#ifdef HAVE_SCROLLBARS #include "scrollbar.h" +#endif + +#ifdef HAVE_TOOLBARS #include "toolbar.h" +#endif + #include "device.h" #define FRAME_TYPE_NAME(f) ((f)->framemeths->name) @@ -48,7 +54,7 @@ struct frame struct console_methods *framemeths; /* Size of text only area of this frame, excluding scrollbars, - toolbars and end of line glyphs. The size can be in charactes + toolbars and end of line glyphs. The size can be in characters or pixels, depending on units in which window system resizes its windows */ int height, width; @@ -60,7 +66,7 @@ struct frame /* Size of text-only are of the frame, in default font characters. This may be inaccurate due to rounding error */ int char_height, char_width; - + /* Size of the whole frame, including scrollbars, toolbars and end of line glyphs, in pixels */ int pixheight, pixwidth; @@ -108,7 +114,7 @@ struct frame #include "frameslots.h" /* Nonzero if frame is currently displayed. - Mutally exclusive with iconfied + Mutually exclusive with iconified JV: This now a tristate flag: Value : Emacs meaning :f-v-p : X meaning 0 : not displayed : nil : unmapped diff --git a/src/free-hook.c b/src/free-hook.c index e44e8cc..07a5edd 100644 --- a/src/free-hook.c +++ b/src/free-hook.c @@ -62,15 +62,7 @@ Boston, MA 02111-1307, USA. */ there will be a large amount, so this might not be very useful. */ -#if defined (EMACS_BTL) && defined (sun4) && !defined (__lucid) -/* currently only works in this configuration */ -# define SAVE_STACK -#endif - #ifdef emacs -#ifdef SAVE_STACK -#include "cadillac-btl.h" -#endif #include #include "lisp.h" #else @@ -93,7 +85,7 @@ void *malloc (unsigned long); /* System function prototypes don't belong in C source files */ /* extern void free (void *); */ -c_hashtable pointer_table; +struct hash_table *pointer_table; extern void (*__free_hook) (void *); extern void *(*__malloc_hook) (unsigned long); @@ -102,12 +94,8 @@ static void *check_malloc (unsigned long); typedef void (*fun_ptr) (); -#ifdef SAVE_STACK -#define FREE_QUEUE_LIMIT 1000 -#else /* free_queue is not too useful without backtrace logging */ #define FREE_QUEUE_LIMIT 1 -#endif #define TRACE_LIMIT 20 typedef struct { @@ -120,98 +108,21 @@ typedef struct { typedef struct { void *address; unsigned long length; -#ifdef SAVE_STACK - fun_entry backtrace[TRACE_LIMIT]; -#endif } free_queue_entry; free_queue_entry free_queue[FREE_QUEUE_LIMIT]; int current_free; -#ifdef SAVE_STACK -static void -init_frame (FRAME *fptr) -{ - FRAME tmp_frame; - -#ifdef sparc - /* Do the system trap ST_FLUSH_WINDOWS */ - asm ("ta 3"); - asm ("st %sp, [%i0+0]"); - asm ("st %fp, [%i0+4]"); -#endif - - fptr->pc = (char *) init_frame; - tmp_frame = *fptr; - - PREVIOUS_FRAME (tmp_frame); - - *fptr = tmp_frame; - return; -} - -#ifdef SAVE_ARGS -static void * -frame_arg (FRAME *fptr, int index) -{ - return ((void *) FRAME_ARG(*fptr, index)); -} -#endif - -static void -save_backtrace (FRAME *current_frame_ptr, fun_entry *table) -{ - int i = 0; -#ifdef SAVE_ARGS - int j; -#endif - FRAME current_frame = *current_frame_ptr; - - /* Get up and out of free() */ - PREVIOUS_FRAME (current_frame); - - /* now do the basic loop adding data until there is no more */ - while (PREVIOUS_FRAME (current_frame) && i < TRACE_LIMIT) - { - table[i].return_pc = (void (*)())FRAME_PC (current_frame); -#ifdef SAVE_ARGS - for (j = 0; j < 3; j++) - table[i].arg[j] = frame_arg (¤t_frame, j); -#endif - i++; - } - memset (&table[i], 0, sizeof (fun_entry) * (TRACE_LIMIT - i)); -} - -free_queue_entry * -find_backtrace (void *ptr) -{ - int i; - - for (i = 0; i < FREE_QUEUE_LIMIT; i++) - if (free_queue[i].address == ptr) - return &free_queue[i]; - - return 0; -} -#endif /* SAVE_STACK */ - int strict_free_check; static void check_free (void *ptr) { -#ifdef SAVE_STACK - FRAME start_frame; - - init_frame (&start_frame); -#endif - __free_hook = 0; __malloc_hook = 0; if (!pointer_table) - pointer_table = make_hashtable (max (100, FREE_QUEUE_LIMIT * 2)); + pointer_table = make_hash_table (max (100, FREE_QUEUE_LIMIT * 2)); if (ptr != 0) { long size; @@ -273,10 +184,7 @@ check_free (void *ptr) #endif free_queue[current_free].address = ptr; free_queue[current_free].length = size; -#ifdef SAVE_STACK - save_backtrace (&start_frame, - free_queue[current_free].backtrace); -#endif + current_free++; if (current_free >= FREE_QUEUE_LIMIT) current_free = 0; @@ -324,7 +232,7 @@ check_malloc (unsigned long size) #endif result = malloc (rounded_up_size); if (!pointer_table) - pointer_table = make_hashtable (FREE_QUEUE_LIMIT * 2); + pointer_table = make_hash_table (FREE_QUEUE_LIMIT * 2); puthash (result, (void *)size, pointer_table); __free_hook = check_free; __malloc_hook = check_malloc; @@ -519,9 +427,6 @@ struct block_input_history_struct int line; blocktype type; int value; -#ifdef SAVE_STACK - fun_entry backtrace[TRACE_LIMIT]; -#endif }; typedef struct block_input_history_struct block_input_history; @@ -554,22 +459,11 @@ note_totally_unblocked (char* file, int line) note_block (char *file, int line, blocktype type) { -#ifdef SAVE_STACK - FRAME start_frame; - - init_frame (&start_frame); -#endif - blhist[blhistptr].file = file; blhist[blhistptr].line = line; blhist[blhistptr].type = type; blhist[blhistptr].value = interrupt_input_blocked; -#ifdef SAVE_STACK - save_backtrace (&start_frame, - blhist[blhistptr].backtrace); -#endif - blhistptr++; if (blhistptr >= BLHISTLIMIT) blhistptr = 0; @@ -601,16 +495,10 @@ log_gcpro (char *file, int line, struct gcpro *value, blocktype type) abort (); OK:; } -#ifdef SAVE_STACK - init_frame (&start_frame); -#endif gcprohist[gcprohistptr].file = file; gcprohist[gcprohistptr].line = line; gcprohist[gcprohistptr].type = type; gcprohist[gcprohistptr].value = (int) value; -#ifdef SAVE_STACK - save_backtrace (&start_frame, gcprohist[gcprohistptr].backtrace); -#endif gcprohistptr++; if (gcprohistptr >= GCPROHISTLIMIT) gcprohistptr = 0; diff --git a/src/getloadavg.c b/src/getloadavg.c index 9af7e53..39c45e6 100644 --- a/src/getloadavg.c +++ b/src/getloadavg.c @@ -58,7 +58,7 @@ Boston, MA 02111-1307, USA. */ __linux__ Linux: assumes /proc filesystem mounted. Support from Michael K. Johnson. __NetBSD__ NetBSD: assumes /kern filesystem mounted. - __OpenBSD__ OpenBSD: dito. + __OpenBSD__ OpenBSD: ditto. In addition, to avoid nesting many #ifdefs, we internally set LDAV_DONE to indicate that the load average has been computed. @@ -563,7 +563,8 @@ getloadavg (double loadavg[], int nelem) } for (elem = 0; elem < nelem; elem++) { - kstat_named_t *kn = kstat_data_lookup (ksp, avestrings[elem]); + kstat_named_t *kn = + (kstat_named_t *) kstat_data_lookup (ksp, avestrings[elem]); if (!kn) { kstat_close (kc); diff --git a/src/gifrlib.h b/src/gifrlib.h index 715cef2..7532001 100644 --- a/src/gifrlib.h +++ b/src/gifrlib.h @@ -36,11 +36,7 @@ typedef unsigned char GifPixelType; typedef unsigned char * GifRowType; typedef unsigned char GifByteType; -#ifdef SYSV -#define VoidPtr char * -#else #define VoidPtr void * -#endif /* SYSV */ typedef struct GifColorType { GifByteType Red, Green, Blue; @@ -167,7 +163,7 @@ extern void GifWarning(GifFileType *GifFile, const char *err_str); /* This is the in-core version of an extension record */ typedef struct { - int ByteCount; + int ByteCount; GifByteType *Bytes; /* on malloc(3) heap */ } ExtensionBlock; diff --git a/src/glyphs-eimage.c b/src/glyphs-eimage.c index bd1fcd7..7e58f9c 100644 --- a/src/glyphs-eimage.c +++ b/src/glyphs-eimage.c @@ -55,10 +55,8 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "frame.h" -#include "insdel.h" #include "opaque.h" -#include "imgproc.h" #include "sysfile.h" #ifdef HAVE_PNG @@ -76,16 +74,6 @@ extern "C" { #include "file-coding.h" #endif -#if INTBITS == 32 -# define FOUR_BYTE_TYPE unsigned int -#elif LONGBITS == 32 -# define FOUR_BYTE_TYPE unsigned long -#elif SHORTBITS == 32 -# define FOUR_BYTE_TYPE unsigned short -#else -#error What kind of strange-ass system are we running on? -#endif - #ifdef HAVE_TIFF DEFINE_IMAGE_INSTANTIATOR_FORMAT (tiff); Lisp_Object Qtiff; @@ -419,7 +407,7 @@ jpeg_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { /* we're relying on the jpeg driver to do any other conversions, or signal an error if the conversion isn't supported. */ - cinfo.out_color_space = JCS_RGB; + cinfo.out_color_space = JCS_RGB; } /* Step 5: Start decompressor */ @@ -465,7 +453,7 @@ jpeg_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, for (i = 0; i < cinfo.output_width; i++) { int clr; - if (jpeg_gray) + if (jpeg_gray) { unsigned char val; #if (BITS_IN_JSAMPLE == 8) @@ -492,10 +480,10 @@ jpeg_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, /* Step 6.5: Create the pixmap and set up the image instance */ /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, cinfo.output_width, cinfo.output_height, - unwind.eimage, dest_mask, + (ii, cinfo.output_width, cinfo.output_height, + unwind.eimage, dest_mask, instantiator, domain)); /* Step 7: Finish decompression */ @@ -576,9 +564,9 @@ static size_t gif_read_from_memory(GifByteType *buf, size_t size, VoidPtr data) { gif_memory_storage *mem = (gif_memory_storage*)data; - + if (size > (mem->len - mem->index)) - return -1; + return (size_t) -1; memcpy(buf, mem->bytes + mem->index, size); mem->index = mem->index + size; return size; @@ -623,20 +611,20 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, Extcount len; int height = 0; int width = 0; - + xzero (unwind); record_unwind_protect (gif_instantiate_unwind, make_opaque_ptr (&unwind)); - + /* 1. Now decode the data. */ - + { Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - + assert (!NILP (data)); - + if (!(unwind.giffile = GifSetup())) signal_image_error ("Insufficent memory to instantiate GIF image", instantiator); - + /* set up error facilities */ if (setjmp(gif_err.setjmp_buffer)) { @@ -647,7 +635,7 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, signal_image_error_2 ("GIF decoding error", errstring, instantiator); } GifSetErrorFunc(unwind.giffile, (Gif_error_func)gif_error_func, (VoidPtr)&gif_err); - + GET_STRING_BINARY_DATA_ALLOCA (data, bytes, len); mem_struct.bytes = bytes; mem_struct.len = len; @@ -655,14 +643,14 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, GifSetReadFunc(unwind.giffile, gif_read_from_memory, (VoidPtr)&mem_struct); GifSetCloseFunc(unwind.giffile, gif_memory_close, (VoidPtr)&mem_struct); DGifInitRead(unwind.giffile); - + /* Then slurp the image into memory, decoding along the way. The result is the image in a simple one-byte-per-pixel format (#### the GIF routines only support 8-bit GIFs, it appears). */ DGifSlurp (unwind.giffile); } - + /* 3. Now create the EImage */ { ColorMapObject *cmo = unwind.giffile->SColorMap; @@ -672,15 +660,15 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, 0, 8, 16, ..., 4, 12, 20, ..., 2, 6, 10, ..., 1, 3, 5, ... */ static int InterlacedOffset[] = { 0, 4, 2, 1 }; static int InterlacedJumps[] = { 8, 8, 4, 2 }; - + height = unwind.giffile->SHeight; width = unwind.giffile->SWidth; unwind.eimage = (unsigned char*) xmalloc (width * height * 3); if (!unwind.eimage) signal_image_error("Unable to allocate enough memory for image", instantiator); - + /* write the data in EImage format (8bit RGB triples) */ - + /* Note: We just use the first image in the file and ignore the rest. We check here that that image covers the full "screen" size. I don't know whether that's always the case. @@ -691,7 +679,7 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, || unwind.giffile->SavedImages[0].ImageDesc.Top != 0) signal_image_error ("First image in GIF file is not full size", instantiator); - + interlace = unwind.giffile->SavedImages[0].ImageDesc.Interlace; pass = 0; row = interlace ? InterlacedOffset[pass] : 0; @@ -701,7 +689,7 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, if (interlace) if (row >= height) { row = InterlacedOffset[++pass]; - while (row > height) + while (row > height) row = InterlacedOffset[++pass]; } eip = unwind.eimage + (row * width * 3); @@ -716,11 +704,11 @@ gif_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, } } /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, width, height, unwind.eimage, dest_mask, + (ii, width, height, unwind.eimage, dest_mask, instantiator, domain)); - + unbind_to (speccount, Qnil); } @@ -778,7 +766,7 @@ struct png_error_struct /* jh 98/03/12 - #### AARRRGH! libpng includes jmp_buf inside its own structure, and there are cases where the size can be different from - between inside the libarary, and inside the code! To do an end run + between inside the library, and inside the code! To do an end run around this, use our own error functions, and don't rely on things passed in the png_ptr to them. This is an ugly hack and must go away when the lisp engine is threaded! */ @@ -848,7 +836,7 @@ png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, png_destroy_read_struct (&png_ptr, (png_infopp)NULL, (png_infopp)NULL); signal_image_error ("Error obtaining memory for png_read", instantiator); } - + xzero (unwind); unwind.png_ptr = png_ptr; unwind.info_ptr = info_ptr; @@ -863,7 +851,7 @@ png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, and is no longer usable for previous versions. jh */ - /* Set the jmp_buf reurn context for png_error ... if this returns !0, then + /* Set the jmp_buf return context for png_error ... if this returns !0, then we ran into a problem somewhere, and need to clean up after ourselves. */ if (setjmp (png_err_stct.setjmp_buffer)) { @@ -903,7 +891,7 @@ png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, /* libpng expects that the image buffer passed in contains a picture to draw on top of if the png has any transparencies. This could be a good place to pass that in... */ - + row_pointers = xnew_array (png_byte *, height); for (y = 0; y < height; y++) @@ -936,18 +924,18 @@ png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, my_background.green = XINT (XCAR (XCDR (rgblist))); my_background.blue = XINT (XCAR (XCDR (XCDR (rgblist)))); } - + if (png_get_bKGD (png_ptr, info_ptr, &image_background)) png_set_background (png_ptr, image_background, PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); - else + else png_set_background (png_ptr, &my_background, PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); } /* Now that we're using EImage, ask for 8bit RGB triples for any type of image*/ - /* convert palatte images to full RGB */ + /* convert palette images to full RGB */ if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE) png_set_expand (png_ptr); /* send grayscale images to RGB too */ @@ -971,7 +959,7 @@ png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, png_read_image (png_ptr, row_pointers); png_read_end (png_ptr, info_ptr); - + #ifdef PNG_SHOW_COMMENTS /* #### * I turn this off by default now, because the !%^@#!% comments @@ -1000,9 +988,9 @@ png_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, } /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, width, height, unwind.eimage, dest_mask, + (ii, width, height, unwind.eimage, dest_mask, instantiator, domain)); /* This will clean up everything else. */ @@ -1106,7 +1094,7 @@ static toff_t tiff_memory_seek(thandle_t data, toff_t off, int whence) if ((newidx > mem->len) || (newidx < 0)) return -1; - + mem->index = newidx; return newidx; } @@ -1206,7 +1194,7 @@ tiff_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, xzero (unwind); record_unwind_protect (tiff_instantiate_unwind, make_opaque_ptr (&unwind)); - + /* set up error facilities */ if (setjmp (tiff_err_data.setjmp_buffer)) { @@ -1248,7 +1236,7 @@ tiff_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, unwind.eimage = (unsigned char *) xmalloc (width * height * 3); /* ### This is little more than proof-of-concept/function testing. - It needs to be reimplimented via scanline reads for both memory + It needs to be reimplemented via scanline reads for both memory compactness. */ raster = (uint32*) _TIFFmalloc (width * height * sizeof (uint32)); if (raster != NULL) @@ -1280,9 +1268,9 @@ tiff_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, } /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, width, height, unwind.eimage, dest_mask, + (ii, width, height, unwind.eimage, dest_mask, instantiator, domain)); unbind_to (speccount, Qnil); diff --git a/src/glyphs-msw.c b/src/glyphs-msw.c index 7366c8e..2de86b6 100644 --- a/src/glyphs-msw.c +++ b/src/glyphs-msw.c @@ -87,9 +87,9 @@ static BITMAPINFO* convert_EImage_to_DIBitmap (Lisp_Object device, if (DEVICE_MSWINDOWS_BITSPIXEL (d) > 0) { int bpline = BPLINE(width * 3); - /* FIXME: we can do this because 24bpp implies no colour table, once - * we start paletizing this is no longer true. The X versions of - * this function quantises to 256 colours or bit masks down to a + /* FIXME: we can do this because 24bpp implies no color table, once + * we start palettizing this is no longer true. The X versions of + * this function quantises to 256 colors or bit masks down to a * long. Windows can actually handle rgb triples in the raw so I * don't see much point trying to optimize down to the best * structure - unless it has memory / color allocation implications @@ -699,7 +699,7 @@ static int xpm_to_eimage (Lisp_Object image, CONST Extbyte *buffer, break; case XpmFileInvalid: { - signal_simple_error ("invalid XPM data", image); + signal_simple_error ("Invalid XPM data", image); } case XpmNoMemory: { @@ -1173,7 +1173,7 @@ mswindows_resource_instantiate (Lisp_Object image_instance, Lisp_Object instanti } else if (!(resid = MAKEINTRESOURCE (resource_name_to_resource (resource_id, type)))) - signal_simple_error ("invalid resource identifier", resource_id); + signal_simple_error ("Invalid resource identifier", resource_id); /* load the image */ if (!(himage = LoadImage (hinst, resid, type, 0, 0, @@ -1181,7 +1181,7 @@ mswindows_resource_instantiate (Lisp_Object image_instance, Lisp_Object instanti LR_SHARED | (!NILP (file) ? LR_LOADFROMFILE : 0)))) { - signal_simple_error ("cannot load image", instantiator); + signal_simple_error ("Cannot load image", instantiator); } if (hinst) @@ -1295,7 +1295,7 @@ in this Software without prior written authorization from the X Consortium. /* - * Based on an optimized version provided by Jim Becker, Auguest 5, 1988. + * Based on an optimized version provided by Jim Becker, August 5, 1988. */ #ifndef BitmapSuccess #define BitmapSuccess 0 diff --git a/src/glyphs-x.c b/src/glyphs-x.c index 70b15e0..82cba3a 100644 --- a/src/glyphs-x.c +++ b/src/glyphs-x.c @@ -122,7 +122,7 @@ convert_EImage_to_XImage (Lisp_Object device, int width, int height, int depth, bitmap_pad, byte_cnt, i, j; int rd,gr,bl,q; unsigned char *data, *ip, *dp; - quant_table *qtable; + quant_table *qtable = 0; union { FOUR_BYTE_TYPE val; char cp[4]; @@ -145,7 +145,7 @@ convert_EImage_to_XImage (Lisp_Object device, int width, int height, (depth > 8) ? 16 : 8); byte_cnt = bitmap_pad >> 3; - + outimg = XCreateImage (dpy, vis, depth, ZPixmap, 0, 0, width, height, bitmap_pad, 0); @@ -158,7 +158,7 @@ convert_EImage_to_XImage (Lisp_Object device, int width, int height, return NULL; } outimg->data = (char *) data; - + if (vis->class == PseudoColor) { unsigned long pixarray[256]; @@ -174,7 +174,7 @@ convert_EImage_to_XImage (Lisp_Object device, int width, int height, { XColor color; int res; - + color.red = qtable->rm[i] ? qtable->rm[i] << 8 : 0; color.green = qtable->gm[i] ? qtable->gm[i] << 8 : 0; color.blue = qtable->bm[i] ? qtable->bm[i] << 8 : 0; @@ -287,7 +287,7 @@ convert_EImage_to_XImage (Lisp_Object device, int width, int height, #endif } } - } + } return outimg; } @@ -469,7 +469,7 @@ x_locate_pixmap_file (Lisp_Object name) } if (NILP (Vdefault_x_device)) - /* This may occur during intialization. */ + /* This may occur during initialization. */ return Qnil; else /* We only check the bitmapFilePath resource on the original X device. */ @@ -609,7 +609,7 @@ write_lisp_string_to_temp_file (Lisp_Object string, char *filename_out) /* reset the dynarr */ Lstream_rewind(ostr); } - + if (fclose (tmpfil) != 0) fubar = 1; Lstream_close (istr); @@ -791,7 +791,7 @@ init_image_instance_from_x_image (struct Lisp_Image_Instance *ii, static void x_init_image_instance_from_eimage (struct Lisp_Image_Instance *ii, int width, int height, - unsigned char *eimage, + unsigned char *eimage, int dest_mask, Lisp_Object instantiator, Lisp_Object domain) @@ -801,7 +801,7 @@ x_init_image_instance_from_eimage (struct Lisp_Image_Instance *ii, unsigned long *pixtbl = NULL; int npixels = 0; XImage* ximage; - + ximage = convert_EImage_to_XImage (device, width, height, eimage, &pixtbl, &npixels); if (!ximage) @@ -809,7 +809,7 @@ x_init_image_instance_from_eimage (struct Lisp_Image_Instance *ii, if (pixtbl) xfree (pixtbl); signal_image_error("EImage to XImage conversion failed", instantiator); } - + /* Now create the pixmap and set up the image instance */ init_image_instance_from_x_image (ii, ximage, dest_mask, cmap, pixtbl, npixels, @@ -826,11 +826,11 @@ x_init_image_instance_from_eimage (struct Lisp_Image_Instance *ii, } } -int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, +int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, unsigned int *height, unsigned char **datap, int *x_hot, int *y_hot) { - return XmuReadBitmapDataFromFile (filename, width, height, + return XmuReadBitmapDataFromFile (filename, width, height, datap, x_hot, y_hot); } @@ -1493,7 +1493,7 @@ xface_validate (Lisp_Object instantiator) static Lisp_Object xface_normalize (Lisp_Object inst, Lisp_Object console_type) { - /* This funcation can call lisp */ + /* This function can call lisp */ Lisp_Object file = Qnil, mask_file = Qnil; struct gcpro gcpro1, gcpro2, gcpro3; Lisp_Object alist = Qnil; @@ -2085,9 +2085,9 @@ finalize_subwindow (void *header, int for_disksave) /* subwindows are equal iff they have the same window XID */ static int -subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth) +subwindow_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - return (XSUBWINDOW (o1)->subwindow == XSUBWINDOW (o2)->subwindow); + return (XSUBWINDOW (obj1)->subwindow == XSUBWINDOW (obj2)->subwindow); } static unsigned long diff --git a/src/glyphs.c b/src/glyphs.c index 86f2cb1..8444f4a 100644 --- a/src/glyphs.c +++ b/src/glyphs.c @@ -526,20 +526,20 @@ mark_image_instance (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj); - (markobj) (i->name); + markobj (i->name); switch (IMAGE_INSTANCE_TYPE (i)) { case IMAGE_TEXT: - (markobj) (IMAGE_INSTANCE_TEXT_STRING (i)); + markobj (IMAGE_INSTANCE_TEXT_STRING (i)); break; case IMAGE_MONO_PIXMAP: case IMAGE_COLOR_PIXMAP: - (markobj) (IMAGE_INSTANCE_PIXMAP_FILENAME (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_FG (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_BG (i)); + markobj (IMAGE_INSTANCE_PIXMAP_FILENAME (i)); + markobj (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i)); + markobj (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i)); + markobj (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i)); + markobj (IMAGE_INSTANCE_PIXMAP_FG (i)); + markobj (IMAGE_INSTANCE_PIXMAP_BG (i)); break; case IMAGE_SUBWINDOW: /* #### implement me */ @@ -673,10 +673,10 @@ finalize_image_instance (void *header, int for_disksave) } static int -image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth) +image_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (o1); - struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (o2); + struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (obj1); + struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (obj2); struct device *d1 = XDEVICE (i1->device); struct device *d2 = XDEVICE (i2->device); @@ -958,14 +958,14 @@ make_image_instance_1 (Lisp_Object data, Lisp_Object device, /* instantiate_image_instantiator() will abort if given an image instance ... */ if (IMAGE_INSTANCEP (data)) - signal_simple_error ("image instances not allowed here", data); + signal_simple_error ("Image instances not allowed here", data); image_validate (data); dest_mask = decode_image_instance_type_list (dest_types); data = normalize_image_instantiator (data, DEVICE_TYPE (XDEVICE (device)), make_int (dest_mask)); GCPRO1 (data); if (VECTORP (data) && EQ (XVECTOR_DATA (data)[0], Qinherit)) - signal_simple_error ("inheritance not allowed here", data); + signal_simple_error ("Inheritance not allowed here", data); ii = instantiate_image_instantiator (device, device, data, Qnil, Qnil, dest_mask); RETURN_UNGCPRO (ii); @@ -1483,7 +1483,7 @@ potential_pixmap_file_instantiator (Lisp_Object instantiator, if (!NILP (file) && NILP (data)) { Lisp_Object retval = MAYBE_LISP_CONTYPE_METH - (decode_console_type(console_type, ERROR_ME), + (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (file)); if (!NILP (retval)) @@ -1491,7 +1491,7 @@ potential_pixmap_file_instantiator (Lisp_Object instantiator, else return Fcons (file, Qnil); /* should have been file */ } - + return Qnil; } @@ -1514,7 +1514,7 @@ simple_image_type_normalize (Lisp_Object inst, Lisp_Object console_type, Note that if we cannot generate any regular inline data, we skip out. */ - file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, + file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, console_type); if (CONSP (file)) /* failure locating filename */ @@ -1600,7 +1600,9 @@ xbm_validate (Lisp_Object instantiator) -- maybe return an error, or return Qnil. */ -#ifndef HAVE_X_WINDOWS +#ifdef HAVE_X_WINDOWS +#include +#else #define XFree(data) free(data) #endif @@ -1614,7 +1616,7 @@ bitmap_to_lisp_data (Lisp_Object name, int *xhot, int *yhot, CONST char *filename_ext; GET_C_STRING_FILENAME_DATA_ALLOCA (name, filename_ext); - result = read_bitmap_data_from_file (filename_ext, &w, &h, + result = read_bitmap_data_from_file (filename_ext, &w, &h, &data, xhot, yhot); if (result == BitmapSuccess) @@ -1675,11 +1677,11 @@ xbm_mask_file_munging (Lisp_Object alist, Lisp_Object file, && !NILP (file)) { mask_file = MAYBE_LISP_CONTYPE_METH - (decode_console_type(console_type, ERROR_ME), + (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (concat2 (file, build_string ("Mask")))); if (NILP (mask_file)) mask_file = MAYBE_LISP_CONTYPE_METH - (decode_console_type(console_type, ERROR_ME), + (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (concat2 (file, build_string ("msk")))); } @@ -1774,9 +1776,9 @@ xbm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { Lisp_Object device= IMAGE_INSTANCE_DEVICE (XIMAGE_INSTANCE (image_instance)); - MAYBE_DEVMETH (XDEVICE (device), + MAYBE_DEVMETH (XDEVICE (device), xbm_instantiate, - (image_instance, instantiator, pointer_fg, + (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain)); } @@ -1943,7 +1945,7 @@ xpm_normalize (Lisp_Object inst, Lisp_Object console_type) Note that if we cannot generate any regular inline data, we skip out. */ - file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, + file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, console_type); if (CONSP (file)) /* failure locating filename */ @@ -1957,7 +1959,7 @@ xpm_normalize (Lisp_Object inst, Lisp_Object console_type) if (NILP (file) && !UNBOUNDP (color_symbols)) /* no conversion necessary */ RETURN_UNGCPRO (inst); - + alist = tagged_vector_to_alist (inst); if (!NILP (file)) @@ -1968,7 +1970,7 @@ xpm_normalize (Lisp_Object inst, Lisp_Object console_type) alist = Fcons (Fcons (Q_file, file), Fcons (Fcons (Q_data, data), alist)); } - + if (UNBOUNDP (color_symbols)) { color_symbols = evaluate_xpm_color_symbols (); @@ -1999,9 +2001,9 @@ xpm_instantiate (Lisp_Object image_instance, Lisp_Object instantiator, { Lisp_Object device= IMAGE_INSTANCE_DEVICE (XIMAGE_INSTANCE (image_instance)); - MAYBE_DEVMETH (XDEVICE (device), + MAYBE_DEVMETH (XDEVICE (device), xpm_instantiate, - (image_instance, instantiator, pointer_fg, + (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain)); } @@ -2029,8 +2031,8 @@ image_mark (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Specifier *image = XIMAGE_SPECIFIER (obj); - ((markobj) (IMAGE_SPECIFIER_ATTACHEE (image))); - ((markobj) (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image))); + markobj (IMAGE_SPECIFIER_ATTACHEE (image)); + markobj (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image)); } static Lisp_Object @@ -2121,11 +2123,11 @@ image_instantiate (Lisp_Object specifier, Lisp_Object matchspec, pointer face. */ - subtable = make_lisp_hashtable (20, - pointerp ? HASHTABLE_KEY_CAR_WEAK - : HASHTABLE_KEY_WEAK, - pointerp ? HASHTABLE_EQUAL - : HASHTABLE_EQ); + subtable = make_lisp_hash_table (20, + pointerp ? HASH_TABLE_KEY_CAR_WEAK + : HASH_TABLE_KEY_WEAK, + pointerp ? HASH_TABLE_EQUAL + : HASH_TABLE_EQ); Fputhash (make_int (dest_mask), subtable, d->image_instance_cache); instance = Qunbound; @@ -2484,10 +2486,10 @@ mark_glyph (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Glyph *glyph = XGLYPH (obj); - ((markobj) (glyph->image)); - ((markobj) (glyph->contrib_p)); - ((markobj) (glyph->baseline)); - ((markobj) (glyph->face)); + markobj (glyph->image); + markobj (glyph->contrib_p); + markobj (glyph->baseline); + markobj (glyph->face); return glyph->plist; } @@ -2516,10 +2518,10 @@ print_glyph (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) This isn't concerned with "unspecified" attributes, that's what #'glyph-differs-from-default-p is for. */ static int -glyph_equal (Lisp_Object o1, Lisp_Object o2, int depth) +glyph_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Glyph *g1 = XGLYPH (o1); - struct Lisp_Glyph *g2 = XGLYPH (o2); + struct Lisp_Glyph *g1 = XGLYPH (obj1); + struct Lisp_Glyph *g2 = XGLYPH (obj2); depth++; @@ -2761,12 +2763,10 @@ The return value will be one of 'buffer, 'pointer, or 'icon. CHECK_GLYPH (glyph); switch (XGLYPH_TYPE (glyph)) { + default: abort (); case GLYPH_BUFFER: return Qbuffer; case GLYPH_POINTER: return Qpointer; case GLYPH_ICON: return Qicon; - default: - abort (); - return Qnil; /* not reached */ } } @@ -3084,7 +3084,7 @@ mark_glyph_cachels (glyph_cachel_dynarr *elements, for (elt = 0; elt < Dynarr_length (elements); elt++) { struct glyph_cachel *cachel = Dynarr_atp (elements, elt); - ((markobj) (cachel->glyph)); + markobj (cachel->glyph); } } diff --git a/src/glyphs.h b/src/glyphs.h index 663eac1..0d49521 100644 --- a/src/glyphs.h +++ b/src/glyphs.h @@ -112,11 +112,10 @@ struct image_instantiator_methods #define IIFORMAT_METH(mstruc, m, args) (((mstruc)->m##_method) args) /* Call a void-returning specifier method, if it exists */ -#define MAYBE_IIFORMAT_METH(mstruc, m, args) \ -do { \ - struct image_instantiator_methods *_maybe_iiformat_meth_mstruc = (mstruc); \ - if (HAS_IIFORMAT_METH_P (_maybe_iiformat_meth_mstruc, m)) \ - IIFORMAT_METH (_maybe_iiformat_meth_mstruc, m, args); \ +#define MAYBE_IIFORMAT_METH(mstruc, m, args) do { \ + struct image_instantiator_methods *maybe_iiformat_meth_mstruc = (mstruc); \ + if (HAS_IIFORMAT_METH_P (maybe_iiformat_meth_mstruc, m)) \ + IIFORMAT_METH (maybe_iiformat_meth_mstruc, m, args); \ } while (0) /* Call a specifier method, if it exists; otherwise return @@ -185,7 +184,7 @@ Lisp_Object find_keyword_in_vector (Lisp_Object vector, Lisp_Object find_keyword_in_vector_or_given (Lisp_Object vector, Lisp_Object keyword, Lisp_Object default_); -Lisp_Object simple_image_type_normalize (Lisp_Object inst, +Lisp_Object simple_image_type_normalize (Lisp_Object inst, Lisp_Object console_type, Lisp_Object image_type_tag); Lisp_Object potential_pixmap_file_instantiator (Lisp_Object instantiator, @@ -403,11 +402,11 @@ Lisp_Object pixmap_to_lisp_data (Lisp_Object name, int ok_if_data_invalid); #ifdef HAVE_WINDOW_SYSTEM Lisp_Object bitmap_to_lisp_data (Lisp_Object name, int *xhot, int *yhot, int ok_if_data_invalid); -int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, +int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, unsigned int *height, unsigned char **datap, int *x_hot, int *y_hot); Lisp_Object xbm_mask_file_munging (Lisp_Object alist, Lisp_Object file, - Lisp_Object mask_file, + Lisp_Object mask_file, Lisp_Object console_type); #endif diff --git a/src/gui-x.c b/src/gui-x.c index ac6f2dc..9921504 100644 --- a/src/gui-x.c +++ b/src/gui-x.c @@ -274,16 +274,16 @@ popup_selection_callback (Widget widget, LWLIB_ID ignored_id, #if 1 /* Eval the activep slot of the menu item */ -# define wv_set_evalable_slot(slot,form) \ - do { Lisp_Object _f_ = (form); \ - slot = (NILP (_f_) ? 0 : \ - EQ (_f_, Qt) ? 1 : \ - !NILP (Feval (_f_))); \ - } while (0) +# define wv_set_evalable_slot(slot,form) do { \ + Lisp_Object wses_form = (form); \ + (slot) = (NILP (wses_form) ? 0 : \ + EQ (wses_form, Qt) ? 1 : \ + !NILP (Feval (wses_form))); \ +} while (0) #else /* Treat the activep slot of the menu item as a boolean */ # define wv_set_evalable_slot(slot,form) \ - slot = (!NILP ((form))) + ((void) (slot = (!NILP (form)))) #endif char * @@ -297,7 +297,8 @@ menu_separator_style (CONST char *s) first = s[0]; if (first != '-' && first != '=') return NULL; - for (p = s; *p == first; p++); + for (p = s; *p == first; p++) + DO_NOTHING; /* #### - cannot currently specify a separator tag "--!tag" and a separator style "--:style" at the same time. */ @@ -361,7 +362,7 @@ button_item_to_widget_value (Lisp_Object desc, widget_value *wv, int selected_spec = 0, included_spec = 0; if (length < 2) - signal_simple_error ("button descriptors must be at least 2 long", desc); + signal_simple_error ("Button descriptors must be at least 2 long", desc); /* length 2: [ "name" callback ] length 3: [ "name" callback active-p ] @@ -386,7 +387,7 @@ button_item_to_widget_value (Lisp_Object desc, widget_value *wv, int i; if (length & 1) signal_simple_error ( - "button descriptor has an odd number of keywords and values", + "Button descriptor has an odd number of keywords and values", desc); name = contents [0]; @@ -396,7 +397,7 @@ button_item_to_widget_value (Lisp_Object desc, widget_value *wv, Lisp_Object key = contents [i++]; Lisp_Object val = contents [i++]; if (!KEYWORDP (key)) - signal_simple_error_2 ("not a keyword", key, desc); + signal_simple_error_2 ("Not a keyword", key, desc); if (EQ (key, Q_active)) active_p = val; else if (EQ (key, Q_suffix)) suffix = val; @@ -411,12 +412,12 @@ button_item_to_widget_value (Lisp_Object desc, widget_value *wv, || CHARP (val)) accel = val; else - signal_simple_error ("bad keyboard accelerator", val); + signal_simple_error ("Bad keyboard accelerator", val); } else if (EQ (key, Q_filter)) signal_simple_error(":filter keyword not permitted on leaf nodes", desc); else - signal_simple_error_2 ("unknown menu item keyword", key, desc); + signal_simple_error_2 ("Unknown menu item keyword", key, desc); } } @@ -529,10 +530,10 @@ button_item_to_widget_value (Lisp_Object desc, widget_value *wv, #endif } else - signal_simple_error_2 ("unknown style", style, desc); + signal_simple_error_2 ("Unknown style", style, desc); if (!allow_text_field_p && (wv->type == TEXT_TYPE)) - signal_simple_error ("text field not allowed in this context", desc); + signal_simple_error ("Text field not allowed in this context", desc); if (selected_spec && EQ (style, Qtext)) signal_simple_error ( diff --git a/src/gui.c b/src/gui.c index 18251ad..de78ca0 100644 --- a/src/gui.c +++ b/src/gui.c @@ -26,7 +26,7 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" #include "gui.h" -#include "bytecode.h" /* for struct Lisp_Compiled_Function */ +#include "bytecode.h" Lisp_Object Q_active, Q_suffix, Q_keys, Q_style, Q_selected; Lisp_Object Q_filter, Q_config, Q_included, Q_key_sequence; diff --git a/src/hash.c b/src/hash.c index 2c13ad1..d7714af 100644 --- a/src/hash.c +++ b/src/hash.c @@ -33,10 +33,16 @@ Boston, MA 02111-1307, USA. */ #endif /* !emacs */ #include "hash.h" -#include "elhash.h" -static CONST unsigned int -primes []={ +#define COMFORTABLE_SIZE(size) (21 * (size) / 16) + +/* Knuth volume 3, hash functions */ +#define WORD_HASH_4(word) (0x9c406b55 * (word)) +#define WORD_HASH_8(word) (0x9c406b549c406b55 * (word)) + +static CONST hash_size_t +primes [] = +{ 13, 29, 37, 47, 59, 71, 89, 107, 131, 163, 197, 239, 293, 353, 431, 521, 631, 761, 919, 1103, 1327, 1597, 1931, 2333, 2801, 3371, 4049, 4861, 5839, 7013, @@ -46,27 +52,21 @@ primes []={ 2009191, 2411033, 2893249 }; -/* strings code */ - -/* from base/generic-hash.cc, and hence from Dragon book, p436 */ -unsigned long -string_hash (CONST void *xv) +#if 0 +static CONST hash_size_t +primes [] = { - unsigned int h = 0; - unsigned CONST char *x = (unsigned CONST char *) xv; - - if (!x) return 0; - - while (*x != 0) - { - unsigned int g; - h = (h << 4) + *x++; - if ((g = h & 0xf0000000) != 0) - h = (h ^ (g >> 24)) ^ g; - } - - return h; -} + 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031, 1361, + 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783, 19219, 24989, + 32491, 42257, 54941, 71429, 92861, 120721, 156941, 204047, 265271, + 344857, 448321, 582821, 757693, 985003, 1280519, 1664681, 2164111, + 2813353, 3657361, 4754591, 6180989, 8035301, 10445899, 13579681, + 17653589, 22949669, 29834603, 38784989, 50420551, 65546729, 85210757, + 110774011, 144006217, 187208107, 243370577, 316381771, 411296309, + 534685237, 695090819, 903618083, 1174703521, 1527114613, 1985248999, + 2580823717, 3355070839, 4361592119 +}; +#endif unsigned long memory_hash (CONST void *xv, size_t size) @@ -76,80 +76,74 @@ memory_hash (CONST void *xv, size_t size) if (!x) return 0; - while (size > 0) + while (size--) { unsigned int g; h = (h << 4) + *x++; if ((g = h & 0xf0000000) != 0) h = (h ^ (g >> 24)) ^ g; - size--; } return h; } -static int -string_eq (CONST void *st1, CONST void *st2) -{ - if (!st1) - return st2 ? 0 : 1; - else if (!st2) - return 0; - else - return !strcmp ( (CONST char *) st1, (CONST char *) st2); -} - - -/* ### Ever heard of binary search? */ -static unsigned int -prime_size (unsigned int size) +/* We've heard of binary search. */ +static hash_size_t +prime_size (hash_size_t size) { - int i; - for (i = 0; i < countof (primes); i++) - if (size <= primes [i]) - return primes [i]; - return primes [countof (primes) - 1]; + int low, high; + for (low = 0, high = countof (primes) - 1; high - low > 1;) + { + /* Loop Invariant: size < primes [high] */ + int mid = (low + high) / 2; + if (primes [mid] < size) + low = mid; + else + high = mid; + } + return primes [high]; } -static void rehash (hentry *harray, c_hashtable ht, unsigned int size); +static void rehash (hentry *harray, struct hash_table *ht, hash_size_t size); #define KEYS_DIFFER_P(old, new, testfun) \ - ((testfun)?(((old) == (new))?0:(!(testfun ((old), new)))):((old) != (new))) + (((old) != (new)) && (!(testfun) || !(testfun) ((old),(new)))) CONST void * -gethash (CONST void *key, c_hashtable hash, CONST void **ret_value) +gethash (CONST void *key, struct hash_table *hash_table, CONST void **ret_value) { - hentry *harray = hash->harray; - int (*test_function) (CONST void *, CONST void *) = hash->test_function; - unsigned int hsize = hash->size; + hentry *harray = hash_table->harray; + hash_table_test_function test_function = hash_table->test_function; + hash_size_t size = hash_table->size; unsigned int hcode_initial = - (hash->hash_function)?(hash->hash_function(key)):((unsigned long) key); - unsigned int hcode = hcode_initial % hsize; + hash_table->hash_function ? + hash_table->hash_function (key) : + (unsigned long) key; + unsigned int hcode = hcode_initial % size; hentry *e = &harray [hcode]; CONST void *e_key = e->key; if (!key) { - *ret_value = hash->zero_entry; - return (void *) hash->zero_set; + *ret_value = hash_table->zero_entry; + return (void *) hash_table->zero_set; } - if ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)) + if (e_key ? + KEYS_DIFFER_P (e_key, key, test_function) : + e->contents == NULL_ENTRY) { - unsigned int h2 = hsize - 2; + size_t h2 = size - 2; unsigned int incr = 1 + (hcode_initial % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; if (hcode >= size) hcode -= size; e = &harray [hcode]; e_key = e->key; } - while ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)); + while (e_key ? + KEYS_DIFFER_P (e_key, key, test_function) : + e->contents == NULL_ENTRY); } *ret_value = e->contents; @@ -157,231 +151,199 @@ gethash (CONST void *key, c_hashtable hash, CONST void **ret_value) } void -clrhash (c_hashtable hash) +clrhash (struct hash_table *hash_table) { - memset (hash->harray, 0, sizeof (hentry) * hash->size); - hash->zero_entry = 0; - hash->zero_set = 0; - hash->fullness = 0; + memset (hash_table->harray, 0, sizeof (hentry) * hash_table->size); + hash_table->zero_entry = 0; + hash_table->zero_set = 0; + hash_table->fullness = 0; } void -free_hashtable (c_hashtable hash) +free_hash_table (struct hash_table *hash_table) { -#ifdef emacs - if (!NILP (hash->elisp_table)) - return; -#endif - xfree (hash->harray); - xfree (hash); + xfree (hash_table->harray); + xfree (hash_table); } -c_hashtable -make_hashtable (unsigned int hsize) +struct hash_table* +make_hash_table (hash_size_t size) { - c_hashtable res = xnew_and_zero (struct _C_hashtable); - res->size = prime_size ((13 * hsize) / 10); - res->harray = xnew_array (hentry, res->size); -#ifdef emacs - res->elisp_table = Qnil; -#endif - clrhash (res); - return res; + struct hash_table *hash_table = xnew_and_zero (struct hash_table); + hash_table->size = prime_size (COMFORTABLE_SIZE (size)); + hash_table->harray = xnew_array (hentry, hash_table->size); + clrhash (hash_table); + return hash_table; } -c_hashtable -make_general_hashtable (unsigned int hsize, - unsigned long (*hash_function) (CONST void *), - int (*test_function) (CONST void *, CONST void *)) +struct hash_table * +make_general_hash_table (hash_size_t size, + hash_table_hash_function hash_function, + hash_table_test_function test_function) { - c_hashtable res = xnew_and_zero (struct _C_hashtable); - res->size = prime_size ((13 * hsize) / 10); - res->harray = xnew_array (hentry, res->size); - res->hash_function = hash_function; - res->test_function = test_function; -#ifdef emacs - res->elisp_table = Qnil; -#endif - clrhash (res); - return res; + struct hash_table* hash_table = make_hash_table (size); + hash_table->hash_function = hash_function; + hash_table->test_function = test_function; + return hash_table; } -c_hashtable -make_strings_hashtable (unsigned int hsize) +#if 0 /* unused strings code */ +struct hash_table * +make_strings_hash_table (hash_size_t size) { - return make_general_hashtable (hsize, string_hash, string_eq); + return make_general_hash_table (size, string_hash, string_eq); } -#ifdef emacs -unsigned int -compute_harray_size (unsigned int hsize) +/* from base/generic-hash.cc, and hence from Dragon book, p436 */ +unsigned long +string_hash (CONST void *xv) { - return prime_size ((13 * hsize) / 10); -} -#endif + unsigned int h = 0; + unsigned CONST char *x = (unsigned CONST char *) xv; -void -copy_hash (c_hashtable dest, c_hashtable src) -{ -#ifdef emacs - /* if these are not the same, then we are losing here */ - if ((NILP (dest->elisp_table)) != (NILP (src->elisp_table))) + if (!x) return 0; + + while (*x != 0) { - error ("Incompatible hashtable types to copy_hash."); - return; + unsigned int g; + h = (h << 4) + *x++; + if ((g = h & 0xf0000000) != 0) + h = (h ^ (g >> 24)) ^ g; } -#endif + return h; +} + +static int +string_eq (CONST void *s1, CONST void *s2) +{ + return s1 && s2 ? !strcmp ((CONST char *) s1, (CONST char *) s2) : s1 == s2; +} +#endif /* unused strings code */ + +void +copy_hash (struct hash_table *dest, struct hash_table *src) +{ if (dest->size != src->size) { -#ifdef emacs - if (!NILP (dest->elisp_table)) - elisp_hvector_free (dest->harray, dest->elisp_table); - else -#endif - xfree (dest->harray); + xfree (dest->harray); dest->size = src->size; -#ifdef emacs - if (!NILP (dest->elisp_table)) - dest->harray = (hentry *) - elisp_hvector_malloc (sizeof (hentry) * dest->size, - dest->elisp_table); - else -#endif - dest->harray = xnew_array (hentry, dest->size); + dest->harray = xnew_array (hentry, dest->size); } - dest->fullness = src->fullness; - dest->zero_entry = src->zero_entry; - dest->zero_set = src->zero_set; + dest->fullness = src->fullness; + dest->zero_entry = src->zero_entry; + dest->zero_set = src->zero_set; dest->hash_function = src->hash_function; dest->test_function = src->test_function; memcpy (dest->harray, src->harray, sizeof (hentry) * dest->size); } static void -grow_hashtable (c_hashtable hash, unsigned int new_size) +grow_hash_table (struct hash_table *hash_table, hash_size_t new_size) { - unsigned int old_hsize = hash->size; - hentry *old_harray = hash->harray; - unsigned int new_hsize = prime_size (new_size); - hentry *new_harray; + hash_size_t old_size = hash_table->size; + hentry *old_harray = hash_table->harray; + hentry *new_harray; -#ifdef emacs - /* We test for Qzero to facilitate free-hook.c. That module creates - a hashtable very very early, at which point Qnil has not yet - been set and is thus all zeroes. Qzero is "automatically" - initialized at startup because its correct value is also all - zeroes. */ - if (!EQ (hash->elisp_table, Qnull_pointer) && - !NILP (hash->elisp_table) && - !ZEROP (hash->elisp_table)) - new_harray = (hentry *) elisp_hvector_malloc (sizeof (hentry) * new_hsize, - hash->elisp_table); - else -#endif - new_harray = (hentry *) xmalloc (sizeof (hentry) * new_hsize); + new_size = prime_size (new_size); - hash->size = new_hsize; - hash->harray = new_harray; + new_harray = xnew_array (hentry, new_size); + + hash_table->size = new_size; + hash_table->harray = new_harray; /* do the rehash on the "grown" table */ { - long old_zero_set = hash->zero_set; - void *old_zero_entry = hash->zero_entry; - clrhash (hash); - hash->zero_set = old_zero_set; - hash->zero_entry = old_zero_entry; - rehash (old_harray, hash, old_hsize); + long old_zero_set = hash_table->zero_set; + void *old_zero_entry = hash_table->zero_entry; + clrhash (hash_table); + hash_table->zero_set = old_zero_set; + hash_table->zero_entry = old_zero_entry; + rehash (old_harray, hash_table, old_size); } -#ifdef emacs - if (!EQ (hash->elisp_table, Qnull_pointer) && - !NILP (hash->elisp_table) && - !ZEROP (hash->elisp_table)) - elisp_hvector_free (old_harray, hash->elisp_table); - else -#endif - xfree (old_harray); + xfree (old_harray); } void -expand_hashtable (c_hashtable hash, unsigned int needed_size) +expand_hash_table (struct hash_table *hash_table, hash_size_t needed_size) { - size_t hsize = hash->size; - size_t comfortable_size = (13 * needed_size) / 10; - if (hsize < comfortable_size) - grow_hashtable (hash, comfortable_size + 1); + hash_size_t size = hash_table->size; + hash_size_t comfortable_size = COMFORTABLE_SIZE (needed_size); + if (size < comfortable_size) + grow_hash_table (hash_table, comfortable_size + 1); } void -puthash (CONST void *key, void *cont, c_hashtable hash) +puthash (CONST void *key, void *contents, struct hash_table *hash_table) { - unsigned int hsize = hash->size; - int (*test_function) (CONST void *, CONST void *) = hash->test_function; - unsigned int fullness = hash->fullness; + hash_table_test_function test_function = hash_table->test_function; + hash_size_t size = hash_table->size; + hash_size_t fullness = hash_table->fullness; hentry *harray; CONST void *e_key; hentry *e; unsigned int hcode_initial = - (hash->hash_function)?(hash->hash_function(key)):((unsigned long) key); + hash_table->hash_function ? + hash_table->hash_function (key) : + (unsigned long) key; unsigned int hcode; unsigned int incr = 0; - unsigned int h2; + size_t h2; CONST void *oldcontents; if (!key) { - hash->zero_entry = cont; - hash->zero_set = 1; + hash_table->zero_entry = contents; + hash_table->zero_set = 1; return; } - if (hsize < (1 + ((13 * fullness) / 10))) + if (size < (1 + COMFORTABLE_SIZE (fullness))) { - grow_hashtable (hash, hsize + 1); - hsize = hash->size; - fullness = hash->fullness; + grow_hash_table (hash_table, size + 1); + size = hash_table->size; + fullness = hash_table->fullness; } - harray= hash->harray; - h2 = hsize - 2; + harray= hash_table->harray; + h2 = size - 2; - hcode = hcode_initial % hsize; + hcode = hcode_initial % size; e_key = harray [hcode].key; - if (e_key && (KEYS_DIFFER_P (e_key, key, test_function))) + if (e_key && KEYS_DIFFER_P (e_key, key, test_function)) { - h2 = hsize - 2; + h2 = size - 2; incr = 1 + (hcode_initial % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; + if (hcode >= size) hcode -= size; e_key = harray [hcode].key; } - while (e_key && (KEYS_DIFFER_P (e_key, key, test_function))); + while (e_key && KEYS_DIFFER_P (e_key, key, test_function)); } oldcontents = harray [hcode].contents; harray [hcode].key = key; - harray [hcode].contents = cont; - /* if the entry that we used was a deleted entry, + harray [hcode].contents = contents; + /* If the entry that we used was a deleted entry, check for a non deleted entry of the same key, - then delete it */ - if (!e_key && (oldcontents == NULL_ENTRY)) + then delete it. */ + if (!e_key && oldcontents == NULL_ENTRY) { if (!incr) incr = 1 + ((unsigned long) key % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; if (hcode >= size) hcode -= size; e = &harray [hcode]; e_key = e->key; } - while ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)); + while (e_key ? + KEYS_DIFFER_P (e_key, key, test_function): + e->contents == NULL_ENTRY); if (e_key) { @@ -391,57 +353,58 @@ puthash (CONST void *key, void *cont, c_hashtable hash) } /* only increment the fullness when we used up a new hentry */ - if (!e_key || (KEYS_DIFFER_P (e_key, key, test_function))) - hash->fullness++; + if (!e_key || KEYS_DIFFER_P (e_key, key, test_function)) + hash_table->fullness++; } static void -rehash (hentry *harray, c_hashtable hash, unsigned int size) +rehash (hentry *harray, struct hash_table *hash_table, hash_size_t size) { hentry *limit = harray + size; hentry *e; for (e = harray; e < limit; e++) { if (e->key) - puthash (e->key, e->contents, hash); + puthash (e->key, e->contents, hash_table); } } void -remhash (CONST void *key, c_hashtable hash) +remhash (CONST void *key, struct hash_table *hash_table) { - hentry *harray = hash->harray; - int (*test_function) (CONST void*, CONST void*) = hash->test_function; - unsigned int hsize = hash->size; + hentry *harray = hash_table->harray; + hash_table_test_function test_function = hash_table->test_function; + hash_size_t size = hash_table->size; unsigned int hcode_initial = - (hash->hash_function)?(hash->hash_function(key)):((unsigned long) key); - unsigned int hcode = hcode_initial % hsize; + (hash_table->hash_function) ? + (hash_table->hash_function (key)) : + ((unsigned long) key); + unsigned int hcode = hcode_initial % size; hentry *e = &harray [hcode]; CONST void *e_key = e->key; if (!key) { - hash->zero_entry = 0; - hash->zero_set = 0; + hash_table->zero_entry = 0; + hash_table->zero_set = 0; return; } - if ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)) + if (e_key ? + KEYS_DIFFER_P (e_key, key, test_function) : + e->contents == NULL_ENTRY) { - unsigned int h2 = hsize - 2; + size_t h2 = size - 2; unsigned int incr = 1 + (hcode_initial % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; if (hcode >= size) hcode -= size; e = &harray [hcode]; e_key = e->key; } - while ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)); + while (e_key? + KEYS_DIFFER_P (e_key, key, test_function): + e->contents == NULL_ENTRY); } if (e_key) { @@ -452,41 +415,38 @@ remhash (CONST void *key, c_hashtable hash) } void -maphash (maphash_function mf, c_hashtable hash, void *arg) +maphash (maphash_function mf, struct hash_table *hash_table, void *arg) { hentry *e; hentry *limit; - if (hash->zero_set) + if (hash_table->zero_set) { - if (((*mf) (0, hash->zero_entry, arg))) + if (mf (0, hash_table->zero_entry, arg)) return; } - for (e = hash->harray, limit = e + hash->size; e < limit; e++) + for (e = hash_table->harray, limit = e + hash_table->size; e < limit; e++) { - if (e->key) - { - if (((*mf) (e->key, e->contents, arg))) - return; - } + if (e->key && mf (e->key, e->contents, arg)) + return; } } void -map_remhash (remhash_predicate predicate, c_hashtable hash, void *arg) +map_remhash (remhash_predicate predicate, struct hash_table *hash_table, void *arg) { hentry *e; hentry *limit; - if (hash->zero_set && ((*predicate) (0, hash->zero_entry, arg))) + if (hash_table->zero_set && predicate (0, hash_table->zero_entry, arg)) { - hash->zero_set = 0; - hash->zero_entry = 0; + hash_table->zero_set = 0; + hash_table->zero_entry = 0; } - for (e = hash->harray, limit = e + hash->size; e < limit; e++) - if ((*predicate) (e->key, e->contents, arg)) + for (e = hash_table->harray, limit = e + hash_table->size; e < limit; e++) + if (predicate (e->key, e->contents, arg)) { e->key = 0; e->contents = NULL_ENTRY; diff --git a/src/hash.h b/src/hash.h index d6646d4..a2dbec5 100644 --- a/src/hash.h +++ b/src/hash.h @@ -26,74 +26,68 @@ typedef struct void *contents; } hentry; -struct _C_hashtable +typedef int (*hash_table_test_function) (CONST void *, CONST void *); +typedef unsigned long (*hash_table_hash_function) (CONST void *); +typedef size_t hash_size_t; + +struct hash_table { hentry *harray; long zero_set; void *zero_entry; - size_t size; /* size of the hasharray */ - unsigned int fullness; /* number of entries in the hashtable */ - unsigned long (*hash_function) (CONST void *); - int (*test_function) (CONST void *, CONST void *); -#ifdef emacs - Lisp_Object elisp_table; -#endif + hash_size_t size; /* size of the hasharray */ + hash_size_t fullness; /* number of entries in the hash table */ + hash_table_hash_function hash_function; + hash_table_test_function test_function; }; -typedef struct _C_hashtable *c_hashtable; - -/* size is the number of initial entries. The hashtable will be grown +/* SIZE is the number of initial entries. The hash table will be grown automatically if the number of entries approaches the size */ -c_hashtable make_hashtable (unsigned int size); +struct hash_table *make_hash_table (hash_size_t size); -c_hashtable make_general_hashtable (unsigned int hsize, - unsigned long (*hash_function) - (CONST void *), - int (*test_function) (CONST void *, - CONST void *)); +struct hash_table * +make_general_hash_table (hash_size_t size, + hash_table_hash_function hash_function, + hash_table_test_function test_function); -c_hashtable make_strings_hashtable (unsigned int hsize); +struct hash_table *make_strings_hash_table (hash_size_t size); -/* clears the hash table. A freshly created hashtable is already cleared up */ -void clrhash (c_hashtable hash); +/* Clear HASH-TABLE. A freshly created hash table is already cleared up. */ +void clrhash (struct hash_table *hash_table); -/* frees the table and substructures */ -void free_hashtable (c_hashtable hash); +/* Free HASH-TABLE and its substructures */ +void free_hash_table (struct hash_table *hash_table); -/* returns a hentry whose key is 0 if the entry does not exist in hashtable */ -CONST void *gethash (CONST void *key, c_hashtable hash, +/* Returns a hentry whose key is 0 if the entry does not exist in HASH-TABLE */ +CONST void *gethash (CONST void *key, struct hash_table *hash_table, CONST void **ret_value); -/* key should be different from 0 */ -void puthash (CONST void *key, void *contents, c_hashtable hash); +/* KEY should be different from 0 */ +void puthash (CONST void *key, void *contents, struct hash_table *hash_table); -/* delete the entry which key is key */ -void remhash (CONST void *key, c_hashtable hash); +/* delete the entry with key KEY */ +void remhash (CONST void *key, struct hash_table *hash_table); typedef int (*maphash_function) (CONST void* key, void* contents, void* arg); typedef int (*remhash_predicate) (CONST void* key, CONST void* contents, void* arg); -typedef void (*generic_hashtable_op) (c_hashtable table, +typedef void (*generic_hash_table_op) (struct hash_table *hash_table, void *arg1, void *arg2, void *arg3); -/* calls mf with the following arguments: key, contents, arg; for every - entry in the hashtable */ -void maphash (maphash_function fn, c_hashtable hash, void* arg); - -/* delete objects from the table which satisfy the predicate */ -void map_remhash (remhash_predicate predicate, c_hashtable hash, void *arg); +/* Call MF (key, contents, arg) for every entry in HASH-TABLE */ +void maphash (maphash_function mf, struct hash_table *hash_table, void* arg); -/* copies all the entries of src into dest -- dest is modified as needed - so it is as big as src. */ -void copy_hash (c_hashtable dest, c_hashtable src); +/* Delete all objects from HASH-TABLE satisfying PREDICATE */ +void map_remhash (remhash_predicate predicate, + struct hash_table *hash_table, void *arg); -/* makes sure that hashtable can hold at least needed_size entries */ -void expand_hashtable (c_hashtable hash, unsigned int needed_size); +/* Copy all the entries from SRC into DEST -- DEST is modified as needed + so it is as big as SRC. */ +void copy_hash (struct hash_table *dest, struct hash_table *src); -#ifdef emacs /* for elhash.c */ -unsigned int compute_harray_size (unsigned int); -#endif +/* Make sure HASH-TABLE can hold at least NEEDED_SIZE entries */ +void expand_hash_table (struct hash_table *hash_table, hash_size_t needed_size); #endif /* _HASH_H_ */ diff --git a/src/hftctl.c b/src/hftctl.c index d60d4d0..d66c480 100644 --- a/src/hftctl.c +++ b/src/hftctl.c @@ -20,7 +20,7 @@ /* 1. determines if fildes is pty */ /* does normal ioctl it is not */ /* 2. places fildes into raw mode */ -/* 3. converts ioctl arguments to datastream */ +/* 3. converts ioctl arguments to data stream */ /* 4. waits for 2 secs for acknowledgement before */ /* timing out. */ /* 5. places response in callers buffer ( just like */ @@ -259,8 +259,8 @@ GT_ACK (fd, req, buf) (i ? memcpy (&ack, p.c, i) : 0); /* if any left over, then move */ p.ack = &ack; /* ESC to front of ack struct */ - p.c += i; /* skip over whats been read */ - i = sizeof (ack) - i; /* set whats left to be read */ + p.c += i; /* skip over what's been read */ + i = sizeof (ack) - i; /* set what's left to be read */ } /***** TRY AGAIN */ alarm(0); /* ACK VTD received, reset alrm*/ diff --git a/src/imgproc.c b/src/imgproc.c index 1306ccc..cbe5d5e 100644 --- a/src/imgproc.c +++ b/src/imgproc.c @@ -23,7 +23,7 @@ Boston, MA 02111-1307, USA. */ /* Original author: Jareth Hein */ /* Parts of this file are based on code from Sam Leffler's tiff library, - with the original copywrite displayed here: + with the original copyright displayed here: Copyright (c) 1988-1997 Sam Leffler Copyright (c) 1991-1997 Silicon Graphics, Inc. diff --git a/src/input-method-xlib.c b/src/input-method-xlib.c index a66ea11..cb8a9b0 100644 --- a/src/input-method-xlib.c +++ b/src/input-method-xlib.c @@ -187,10 +187,10 @@ XIM_init_frame (struct frame *f) static XtResource resources[] = { /* name class represent'n field default value */ - res(XtNximStyles, XtCXimStyles, XtRXimStyles, styles, DefaultXIMStyles), - res(XtNfontSet, XtCFontSet, XtRFontSet, fontset, XtDefaultFontSet), - res(XtNximForeground, XtCForeground, XtRPixel, fg, XtDefaultForeground), - res(XtNximBackground, XtCBackground, XtRPixel, bg, XtDefaultBackground) + res(XtNximStyles, XtCXimStyles, XtRXimStyles, styles, (XtPointer) DefaultXIMStyles), + res(XtNfontSet, XtCFontSet, XtRFontSet, fontset, (XtPointer) XtDefaultFontSet), + res(XtNximForeground, XtCForeground, XtRPixel, fg, (XtPointer) XtDefaultForeground), + res(XtNximBackground, XtCBackground, XtRPixel, bg, (XtPointer) XtDefaultBackground) }; assert (win != 0 && w != NULL && d != NULL); @@ -385,14 +385,14 @@ get_XIM_input (XKeyPressedEvent *x_key_event, XIC ic, Display *dpy) int i; XClientMessageEvent new_event; -try_again: +retry: len = XwcLookupString (ic, x_key_event, composed_input_buf.data, composed_input_buf.size, &keysym, &status); switch (status) { case XBufferOverflow: /* GROW_WC_STRING (&composed_input_buf, 32); mrb */ - goto try_again; + goto retry; case XLookupChars: break; default: diff --git a/src/insdel.c b/src/insdel.c index a85481c..08d191d 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -1886,7 +1886,7 @@ make_gap (struct buffer *buf, Bytecount increment) Bytecount old_gap_size; /* If we have to get more space, get enough to last a while. We use - a geometric progession that saves on realloc space. */ + a geometric progression that saves on realloc space. */ increment += 2000 + ((BI_BUF_Z (buf) - BI_BUF_BEG (buf)) / 8); if (increment > BUF_END_GAP_SIZE (buf)) @@ -3167,7 +3167,7 @@ convert_bufbyte_string_into_emchar_dynarr (CONST Bufbyte *str, Bytecount len, } } -int +Charcount convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, Bytecount len, Emchar *arr) { diff --git a/src/intl.c b/src/intl.c index da4ac18..95249d4 100644 --- a/src/intl.c +++ b/src/intl.c @@ -123,7 +123,7 @@ Window main_window; /* Convenient way to refer to main Era window. */ insertion into the buffer of the whole string. It might require some care, though, to avoid fragmenting memory through the allocation and freeing of many small chunks. Maybe the existing system for - (single-byte) string allocation can be used, multipling the length by + (single-byte) string allocation can be used, multiplying the length by sizeof (wchar_t) to get the right size. */ void @@ -136,14 +136,14 @@ x_get_composed_input (XKeyPressedEvent *x_key_event, XIC context, int i; XClientMessageEvent new_event; - try_again: + retry: len = XwcLookupString (context, x_key_event, composed_input_buf.data, composed_input_buf.size, &keysym, &status); switch (status) { case XBufferOverflow: /* GROW_WC_STRING (&composed_input_buf, 32); mrb */ - goto try_again; + goto retry; case XLookupChars: break; default: diff --git a/src/keymap.c b/src/keymap.c index e2a5152..2b5a18e 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -30,7 +30,6 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "bytecode.h" -#include "commands.h" #include "console.h" #include "elhash.h" #include "events.h" @@ -157,7 +156,7 @@ Boston, MA 02111-1307, USA. */ */ -struct keymap +typedef struct Lisp_Keymap { struct lcrecord_header header; Lisp_Object parents; /* Keymaps to be searched after this one @@ -183,12 +182,7 @@ struct keymap This should be the same as the fullness of the `table', but hash.c is broken. */ Lisp_Object name; /* Just for debugging convenience */ -}; - -#define XKEYMAP(x) XRECORD (x, keymap, struct keymap) -#define XSETKEYMAP(x, p) XSETRECORD (x, p, keymap) -#define KEYMAPP(x) RECORDP (x, keymap) -#define CHECK_KEYMAP(x) CHECK_RECORD (x, keymap) +} Lisp_Keymap; #define MAKE_MODIFIER_HASH_KEY(modifier) make_int (modifier) #define MODIFIER_HASH_KEY_BITS(x) (INTP (x) ? XINT (x) : 0) @@ -260,13 +254,13 @@ Lisp_Object QLFD, QTAB, QRET, QESC, QDEL, QSPC, QBS; static Lisp_Object mark_keymap (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct keymap *keymap = XKEYMAP (obj); - ((markobj) (keymap->parents)); - ((markobj) (keymap->prompt)); - ((markobj) (keymap->inverse_table)); - ((markobj) (keymap->sub_maps_cache)); - ((markobj) (keymap->default_binding)); - ((markobj) (keymap->name)); + Lisp_Keymap *keymap = XKEYMAP (obj); + markobj (keymap->parents); + markobj (keymap->prompt); + markobj (keymap->inverse_table); + markobj (keymap->sub_maps_cache); + markobj (keymap->default_binding); + markobj (keymap->name); return keymap->table; } @@ -274,7 +268,7 @@ static void print_keymap (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { /* This function can GC */ - struct keymap *keymap = XKEYMAP (obj); + Lisp_Keymap *keymap = XKEYMAP (obj); char buf[200]; int size = XINT (Fkeymap_fullness (obj)); if (print_readably) @@ -294,7 +288,7 @@ print_keymap (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) /* No need for keymap_equal #### Why not? */ DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap, mark_keymap, print_keymap, 0, 0, 0, - struct keymap); + Lisp_Keymap); /************************************************************************/ /* Traversing keymaps and their parents */ @@ -475,7 +469,7 @@ static Lisp_Object keymap_lookup_directly (Lisp_Object keymap, Lisp_Object keysym, unsigned int modifiers) { - struct keymap *k; + Lisp_Keymap *k; if ((modifiers & ~(MOD_CONTROL | MOD_META | MOD_SUPER | MOD_HYPER | MOD_ALT | MOD_SHIFT)) != 0) @@ -534,7 +528,7 @@ keymap_store_inverse_internal (Lisp_Object inverse_table, } else { - while (CONSP (Fcdr (keys))) + while (CONSP (XCDR (keys))) keys = XCDR (keys); XCDR (keys) = Fcons (XCDR (keys), keysym); /* No need to call puthash because we've destructively @@ -584,7 +578,7 @@ keymap_delete_inverse_internal (Lisp_Object inverse_table, static void -keymap_store_internal (Lisp_Object keysym, struct keymap *keymap, +keymap_store_internal (Lisp_Object keysym, Lisp_Keymap *keymap, Lisp_Object value) { Lisp_Object prev_value = Fgethash (keysym, keymap->table, Qnil); @@ -613,7 +607,7 @@ keymap_store_internal (Lisp_Object keysym, struct keymap *keymap, static Lisp_Object -create_bucky_submap (struct keymap *k, unsigned int modifiers, +create_bucky_submap (Lisp_Keymap *k, unsigned int modifiers, Lisp_Object parent_for_debugging_info) { Lisp_Object submap = Fmake_sparse_keymap (Qnil); @@ -634,7 +628,7 @@ keymap_store (Lisp_Object keymap, CONST struct key_data *key, { Lisp_Object keysym = key->keysym; unsigned int modifiers = key->modifiers; - struct keymap *k; + Lisp_Keymap *k; if ((modifiers & ~(MOD_CONTROL | MOD_META | MOD_SUPER | MOD_HYPER | MOD_ALT | MOD_SHIFT)) != 0) @@ -683,32 +677,27 @@ struct keymap_submaps_closure }; static int -keymap_submaps_mapper_0 (CONST void *hash_key, void *hash_contents, +keymap_submaps_mapper_0 (Lisp_Object key, Lisp_Object value, void *keymap_submaps_closure) { /* This function can GC */ - Lisp_Object contents; - VOID_TO_LISP (contents, hash_contents); /* Perform any autoloads, etc */ - Fkeymapp (contents); + Fkeymapp (value); return 0; } static int -keymap_submaps_mapper (CONST void *hash_key, void *hash_contents, +keymap_submaps_mapper (Lisp_Object key, Lisp_Object value, void *keymap_submaps_closure) { /* This function can GC */ - Lisp_Object key, contents; Lisp_Object *result_locative; struct keymap_submaps_closure *cl = (struct keymap_submaps_closure *) keymap_submaps_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); result_locative = cl->result_locative; - if (!NILP (Fkeymapp (contents))) - *result_locative = Fcons (Fcons (key, contents), *result_locative); + if (!NILP (Fkeymapp (value))) + *result_locative = Fcons (Fcons (key, value), *result_locative); return 0; } @@ -719,7 +708,7 @@ static Lisp_Object keymap_submaps (Lisp_Object keymap) { /* This function can GC */ - struct keymap *k = XKEYMAP (keymap); + Lisp_Keymap *k = XKEYMAP (keymap); if (EQ (k->sub_maps_cache, Qt)) /* Unknown */ { @@ -750,28 +739,31 @@ keymap_submaps (Lisp_Object keymap) /************************************************************************/ static Lisp_Object -make_keymap (int size) +make_keymap (size_t size) { Lisp_Object result; - struct keymap *keymap = alloc_lcrecord_type (struct keymap, lrecord_keymap); + Lisp_Keymap *keymap = alloc_lcrecord_type (Lisp_Keymap, lrecord_keymap); XSETKEYMAP (result, keymap); - keymap->parents = Qnil; - keymap->table = Qnil; - keymap->prompt = Qnil; + keymap->parents = Qnil; + keymap->prompt = Qnil; + keymap->table = Qnil; + keymap->inverse_table = Qnil; keymap->default_binding = Qnil; - keymap->inverse_table = Qnil; - keymap->sub_maps_cache = Qnil; /* No possible submaps */ - keymap->fullness = 0; + keymap->sub_maps_cache = Qnil; /* No possible submaps */ + keymap->fullness = 0; + keymap->name = Qnil; + if (size != 0) /* hack for copy-keymap */ { - keymap->table = Fmake_hashtable (make_int (size), Qnil); + keymap->table = + make_lisp_hash_table (size, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); /* Inverse table is often less dense because of duplicate key-bindings. If not, it will grow anyway. */ - keymap->inverse_table = Fmake_hashtable (make_int (size * 3 / 4), Qnil); + keymap->inverse_table = + make_lisp_hash_table (size * 3 / 4, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); } - keymap->name = Qnil; return result; } @@ -1114,38 +1106,34 @@ struct copy_keymap_inverse_closure }; static int -copy_keymap_inverse_mapper (CONST void *hash_key, void *hash_contents, +copy_keymap_inverse_mapper (Lisp_Object key, Lisp_Object value, void *copy_keymap_inverse_closure) { - Lisp_Object key, inverse_table, inverse_contents; struct copy_keymap_inverse_closure *closure = (struct copy_keymap_inverse_closure *) copy_keymap_inverse_closure; - VOID_TO_LISP (inverse_table, closure); - VOID_TO_LISP (inverse_contents, hash_contents); - CVOID_TO_LISP (key, hash_key); /* copy-sequence deals with dotted lists. */ - if (CONSP (inverse_contents)) - inverse_contents = Fcopy_sequence (inverse_contents); - Fputhash (key, inverse_contents, closure->inverse_table); + if (CONSP (value)) + value = Fcopy_list (value); + Fputhash (key, value, closure->inverse_table); return 0; } static Lisp_Object -copy_keymap_internal (struct keymap *keymap) +copy_keymap_internal (Lisp_Keymap *keymap) { Lisp_Object nkm = make_keymap (0); - struct keymap *new_keymap = XKEYMAP (nkm); + Lisp_Keymap *new_keymap = XKEYMAP (nkm); struct copy_keymap_inverse_closure copy_keymap_inverse_closure; copy_keymap_inverse_closure.inverse_table = keymap->inverse_table; - new_keymap->parents = Fcopy_sequence (keymap->parents); - new_keymap->fullness = keymap->fullness; + new_keymap->parents = Fcopy_sequence (keymap->parents); + new_keymap->fullness = keymap->fullness; new_keymap->sub_maps_cache = Qnil; /* No submaps */ - new_keymap->table = Fcopy_hashtable (keymap->table); - new_keymap->inverse_table = Fcopy_hashtable (keymap->inverse_table); + new_keymap->table = Fcopy_hash_table (keymap->table); + new_keymap->inverse_table = Fcopy_hash_table (keymap->inverse_table); /* After copying the inverse map, we need to copy the conses which are its values, lest they be shared by the copy, and mangled. */ @@ -1159,30 +1147,26 @@ static Lisp_Object copy_keymap (Lisp_Object keymap); struct copy_keymap_closure { - struct keymap *self; + Lisp_Keymap *self; }; static int -copy_keymap_mapper (CONST void *hash_key, void *hash_contents, +copy_keymap_mapper (Lisp_Object key, Lisp_Object value, void *copy_keymap_closure) { /* This function can GC */ - Lisp_Object key, contents; struct copy_keymap_closure *closure = (struct copy_keymap_closure *) copy_keymap_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); /* When we encounter a keymap which is indirected through a symbol, we need to copy the sub-map. In v18, the form (lookup-key (copy-keymap global-map) "\C-x") returned a new keymap, not the symbol 'Control-X-prefix. */ - contents = get_keymap (contents, - 0, 1); /* #### autoload GC-safe here? */ - if (KEYMAPP (contents)) + value = get_keymap (value, 0, 1); /* #### autoload GC-safe here? */ + if (KEYMAPP (value)) keymap_store_internal (key, closure->self, - copy_keymap (contents)); + copy_keymap (value)); return 0; } @@ -1284,12 +1268,12 @@ define_key_check_and_coerce_keysym (Lisp_Object spec, /* #### This bites! I want to be able to write (control shift a) */ if (modifiers & MOD_SHIFT) signal_simple_error - ("the `shift' modifier may not be applied to ASCII keysyms", + ("The `shift' modifier may not be applied to ASCII keysyms", spec); } else { - signal_simple_error ("unknown keysym specifier", + signal_simple_error ("Unknown keysym specifier", *keysym); } @@ -1474,19 +1458,19 @@ define_key_parser (Lisp_Object spec, struct key_data *returned_value) if (!NILP (XCDR (rest))) { if (! modifier) - signal_simple_error ("unknown modifier", keysym); + signal_simple_error ("Unknown modifier", keysym); } else { if (modifier) - signal_simple_error ("nothing but modifiers here", + signal_simple_error ("Nothing but modifiers here", spec); } rest = XCDR (rest); QUIT; } if (!NILP (rest)) - signal_simple_error ("dotted list", spec); + signal_simple_error ("List must be nil-terminated", spec); define_key_check_and_coerce_keysym (spec, &keysym, modifiers); returned_value->keysym = keysym; @@ -1494,7 +1478,7 @@ define_key_parser (Lisp_Object spec, struct key_data *returned_value) } else { - signal_simple_error ("unknown key-sequence specifier", + signal_simple_error ("Unknown key-sequence specifier", spec); } } @@ -1513,7 +1497,7 @@ key_desc_list_to_event (Lisp_Object list, Lisp_Object event, { Lisp_Object fn, arg; if (! NILP (Fcdr (Fcdr (list)))) - signal_simple_error ("invalid menu event desc", list); + signal_simple_error ("Invalid menu event desc", list); arg = Fcar (Fcdr (list)); if (SYMBOLP (arg)) fn = Qcall_interactively; @@ -1621,6 +1605,12 @@ This can be useful, e.g., to determine if the user pressed `help-char' or ? Qt : Qnil); } +#define MACROLET(k,m) do { \ + returned_value->keysym = (k); \ + returned_value->modifiers = (m); \ + RETURN_SANS_WARNINGS; \ +} while (0) + /* ASCII grunge. Given a keysym, return another keysym/modifier pair which could be considered the same key in an ASCII world. Backspace returns ^H, for @@ -1636,9 +1626,6 @@ define_key_alternate_name (struct key_data *key, unsigned int modifiers_sans_meta = (modifiers & (~MOD_META)); returned_value->keysym = Qnil; /* By default, no "alternate" key */ returned_value->modifiers = 0; -#define MACROLET(k,m) do { returned_value->keysym = (k); \ - returned_value->modifiers = (m); \ - RETURN__; } while (0) if (modifiers_sans_meta == MOD_CONTROL) { if EQ (keysym, QKspace) @@ -1970,7 +1957,7 @@ these features. keymap_store (keymap, &raw_key1, cmd); } if (NILP (Fkeymapp (cmd))) - signal_simple_error_2 ("invalid prefix keys in sequence", + signal_simple_error_2 ("Invalid prefix keys in sequence", c, keys); if (ascii_hack && !NILP (raw_key2.keysym) && @@ -2057,7 +2044,7 @@ raw_lookup_key_mapper (Lisp_Object k, void *arg) * element is the meta-prefix-char will return the keymap that * the "meta" keys are stored in, if there is no binding for * the meta-prefix-char (and if this map has a "meta" submap). - * If this map doesnt have a "meta" submap, then the + * If this map doesn't have a "meta" submap, then the * meta-prefix-char is looked up just like any other key. */ if (remaining == 0) @@ -2226,7 +2213,7 @@ it takes to reach a non-prefix command. map of the buffer in which the mouse was clicked in event0 is a click. It would be kind of nice if this were in Lisp so that this semi-hairy - semi-heuristic command-lookup behaviour could be readily understood and + semi-heuristic command-lookup behavior could be readily understood and customised. However, this needs to be pretty fast, or performance of keyboard macros goes to shit; putting this in lisp slows macros down 2-3x. And they're already slower than v18 by 5-6x. @@ -2410,7 +2397,7 @@ get_relevant_keymaps (Lisp_Object keys, { int nmaps = closure.nmaps; - /* Silently truncate at 100 keymaps to prevent infinite losssage */ + /* Silently truncate at 100 keymaps to prevent infinite lossage */ if (nmaps >= max_maps && max_maps > 0) maps[max_maps - 1] = Vcurrent_global_map; else @@ -2426,7 +2413,7 @@ get_relevant_keymaps (Lisp_Object keys, first element in the list returned. This is so we can correctly search the keymaps associated with glyphs which may be physically disjoint from their extents: for example, if a glyph is out in the - margin, we should still consult the kemyap of that glyph's extent, + margin, we should still consult the keymap of that glyph's extent, which may not itself be under the mouse. */ @@ -2751,26 +2738,22 @@ struct map_keymap_unsorted_closure /* used by map_keymap() */ static int -map_keymap_unsorted_mapper (CONST void *hash_key, void *hash_contents, +map_keymap_unsorted_mapper (Lisp_Object keysym, Lisp_Object value, void *map_keymap_unsorted_closure) { /* This function can GC */ - Lisp_Object keysym; - Lisp_Object contents; struct map_keymap_unsorted_closure *closure = (struct map_keymap_unsorted_closure *) map_keymap_unsorted_closure; unsigned int modifiers = closure->modifiers; unsigned int mod_bit; - CVOID_TO_LISP (keysym, hash_key); - VOID_TO_LISP (contents, hash_contents); mod_bit = MODIFIER_HASH_KEY_BITS (keysym); if (mod_bit != 0) { int omod = modifiers; closure->modifiers = (modifiers | mod_bit); - contents = get_keymap (contents, 1, 0); + value = get_keymap (value, 1, 0); elisp_maphash (map_keymap_unsorted_mapper, - XKEYMAP (contents)->table, + XKEYMAP (value)->table, map_keymap_unsorted_closure); closure->modifiers = omod; } @@ -2779,7 +2762,7 @@ map_keymap_unsorted_mapper (CONST void *hash_key, void *hash_contents, struct key_data key; key.keysym = keysym; key.modifiers = modifiers; - ((*closure->fn) (&key, contents, closure->arg)); + ((*closure->fn) (&key, value, closure->arg)); } return 0; } @@ -2792,16 +2775,13 @@ struct map_keymap_sorted_closure /* used by map_keymap_sorted() */ static int -map_keymap_sorted_mapper (CONST void *hash_key, void *hash_contents, +map_keymap_sorted_mapper (Lisp_Object key, Lisp_Object value, void *map_keymap_sorted_closure) { struct map_keymap_sorted_closure *cl = (struct map_keymap_sorted_closure *) map_keymap_sorted_closure; - Lisp_Object key, contents; Lisp_Object *list = cl->result_locative; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - *list = Fcons (Fcons (key, contents), *list); + *list = Fcons (Fcons (key, value), *list); return 0; } @@ -2899,7 +2879,7 @@ map_keymap_sorted (Lisp_Object keymap_table, struct gcpro gcpro1; Lisp_Object contents = Qnil; - if (XINT (Fhashtable_fullness (keymap_table)) == 0) + if (XINT (Fhash_table_count (keymap_table)) == 0) return; GCPRO1 (contents); @@ -3269,7 +3249,7 @@ of a key read from the user rather than a character from a buffer. #endif strcpy (bufp, (char *) string_data (XSYMBOL (keysym)->name)); if (!NILP (XCDR (rest))) - signal_simple_error ("invalid key description", + signal_simple_error ("Invalid key description", key); } } @@ -3752,7 +3732,7 @@ Fifth argument MOUSE-ONLY-P says to only print bindings for mouse clicks. } -/* Insert a desription of the key bindings in STARTMAP, +/* Insert a description of the key bindings in STARTMAP, followed by those of all maps reachable through STARTMAP. If PARTIAL is nonzero, omit certain "uninteresting" commands (such as `undefined'). @@ -3936,7 +3916,7 @@ describe_map_mapper (CONST struct key_data *key, Lisp_Object keysym = key->keysym; unsigned int modifiers = key->modifiers; - /* Dont mention suppressed commands. */ + /* Don't mention suppressed commands. */ if (SYMBOLP (binding) && !NILP (closure->partial) && !NILP (Fget (binding, closure->partial, Qnil))) @@ -4143,7 +4123,7 @@ describe_map (Lisp_Object keymap, Lisp_Object elt_prefix, { Lisp_Object code = Fget (keysym, Vcharacter_set_property, Qnil); Emchar c = (CHAR_OR_CHAR_INTP (code) - ? XCHAR_OR_CHAR_INT (code) : -1); + ? XCHAR_OR_CHAR_INT (code) : (Emchar) -1); /* Calling Fsingle_key_description() would cons more */ #if 0 /* This is bogus */ if (EQ (keysym, QKlinefeed)) diff --git a/src/keymap.h b/src/keymap.h index 3e9569c..bb0c8a0 100644 --- a/src/keymap.h +++ b/src/keymap.h @@ -24,8 +24,8 @@ Boston, MA 02111-1307, USA. */ #ifndef _XEMACS_KEYMAP_H_ #define _XEMACS_KEYMAP_H_ -DECLARE_LRECORD (keymap, struct keymap); -#define XKEYMAP(x) XRECORD (x, keymap, struct keymap) +DECLARE_LRECORD (keymap, struct Lisp_Keymap); +#define XKEYMAP(x) XRECORD (x, keymap, struct Lisp_Keymap) #define XSETKEYMAP(x, p) XSETRECORD (x, p, keymap) #define KEYMAPP(x) RECORDP (x, keymap) #define GC_KEYMAPP(x) GC_RECORDP (x, keymap) diff --git a/src/line-number.c b/src/line-number.c index 05b42ff..2b930ba 100644 --- a/src/line-number.c +++ b/src/line-number.c @@ -52,7 +52,6 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" #include "buffer.h" -#include "insdel.h" #include "line-number.h" @@ -81,7 +80,7 @@ Boston, MA 02111-1307, USA. */ /* Initialize the cache. Cache is (in pseudo-BNF): CACHE = nil | INITIALIZED-CACHE - INITITIALIZED-CACHE = cons (RING, BEGV-LINE) + INITIALIZED-CACHE = cons (RING, BEGV-LINE) RING = vector (*RING-ELEMENT) RING-ELEMENT = nil | RING-PAIR RING-PAIR = cons (marker, integer) diff --git a/src/linuxplay.c b/src/linuxplay.c index bfe3e7d..f5fe236 100644 --- a/src/linuxplay.c +++ b/src/linuxplay.c @@ -820,7 +820,7 @@ static int audio_init(int mixx_fd, int auddio_fd, int fmt, int speed, perror("SNDCTL_DSP_SYNC"); return(0); } - /* Initialize sound hardware with prefered parameters */ + /* Initialize sound hardware with preferred parameters */ /* If the sound hardware cannot support 16 bit format or requires a different byte sex then try to drop to 8 bit format */ @@ -993,9 +993,8 @@ static void linux_play_data_or_file(int fd,unsigned char *data, return; } /* The VoxWare-SDK discourages opening /dev/audio; opening /dev/dsp and - properly intializing it via ioctl() is prefered */ - if ((audio_fd=open(audio_dev, - (O_WRONLY|O_NDELAY),0)) < 0) { + properly initializing it via ioctl() is preferred */ + if ((audio_fd=open(audio_dev, O_WRONLY | O_NONBLOCK, 0)) < 0) { perror(audio_dev); if (mix_fd > 0 && mix_fd != audio_fd) { close(mix_fd); mix_fd = -1; } return; } diff --git a/src/lisp-disunion.h b/src/lisp-disunion.h index 2ac90c8..6ca10ef 100644 --- a/src/lisp-disunion.h +++ b/src/lisp-disunion.h @@ -109,10 +109,11 @@ typedef EMACS_INT Lisp_Object; #ifdef USE_MINIMAL_TAGBITS +# define Lisp_Type_Int_Bit (Lisp_Type_Int_Even & Lisp_Type_Int_Odd) # define XUNMARK(x) DO_NOTHING # define make_obj(vartype, x) ((Lisp_Object) (x)) -# define make_int(x) ((Lisp_Object) (((x) << INT_GCBITS) + 1)) -# define make_char(x) ((Lisp_Object) (((x) << GCBITS) + Lisp_Type_Char)) +# define make_int(x) ((Lisp_Object) (((x) << INT_GCBITS) | Lisp_Type_Int_Bit)) +# define make_char(x) ((Lisp_Object) (((x) << GCBITS) | Lisp_Type_Char)) # define VALMASK (((1UL << VALBITS) - 1UL) << GCTYPEBITS) # define XTYPE(x) ((enum Lisp_Type) (((EMACS_UINT)(x)) & ~VALMASK)) # define XPNTRVAL(x) (x) /* This depends on Lisp_Type_Record == 0 */ @@ -120,8 +121,7 @@ typedef EMACS_INT Lisp_Object; # define GC_EQ(x,y) EQ (x,y) # define XREALINT(x) ((x) >> INT_GCBITS) # define XUINT(x) ((EMACS_UINT)(x) >> INT_GCBITS) -# define INTP(x) ((EMACS_UINT)(x) & 1) -# define Qzero ((Lisp_Object) 1UL) +# define INTP(x) ((EMACS_UINT)(x) & Lisp_Type_Int_Bit) #else /* !USE_MINIMAL_TAGBITS */ @@ -142,11 +142,11 @@ typedef EMACS_INT Lisp_Object; # define XREALINT(x) (((x) << INT_GCBITS) >> INT_GCBITS) # define XUINT(x) ((EMACS_UINT) ((x) & VALMASK)) # define INTP(x) (XTYPE (x) == Lisp_Type_Int) -# define Qzero ((Lisp_Object) Lisp_Type_Int) #endif /* !USE_MINIMAL_TAGBITS */ -#define Qnull_pointer 0 +#define Qzero make_int (0) +#define Qnull_pointer ((Lisp_Object) 0) #define XGCTYPE(x) XTYPE(x) #define EQ(x,y) ((x) == (y)) #define XSETINT(var, value) ((void) ((var) = make_int (value))) diff --git a/src/lisp-union.h b/src/lisp-union.h index 1406781..94461e6 100644 --- a/src/lisp-union.h +++ b/src/lisp-union.h @@ -89,29 +89,38 @@ Lisp_Object; #define XCHARVAL(x) ((x).gu.val) #ifdef USE_MINIMAL_TAGBITS + # define XSETINT(var, value) do { \ - Lisp_Object *_xzx = &(var); \ - _xzx->s.val = (value); \ - _xzx->s.bits = 1; \ + EMACS_INT xset_value = (value); \ + Lisp_Object *xset_var = &(var); \ + xset_var->s.bits = 1; \ + xset_var->s.val = xset_value; \ } while (0) # define XSETCHAR(var, value) do { \ - Lisp_Object *_xzx = &(var); \ - _xzx->gu.val = (EMACS_UINT) (value); \ - _xzx->gu.type = Lisp_Type_Char; \ + Emchar xset_value = (value); \ + Lisp_Object *xset_var = &(var); \ + xset_var->gu.type = Lisp_Type_Char; \ + xset_var->gu.val = xset_value; \ +} while (0) +# define XSETOBJ(var, vartype, value) do { \ + EMACS_UINT xset_value = (EMACS_UINT) (value); \ + (var).ui = xset_value; \ } while (0) -# define XSETOBJ(var, vartype, value) \ - ((void) ((var).ui = (EMACS_UINT) (value))) # define XPNTRVAL(x) ((x).ui) + #else /* ! USE_MINIMAL_TAGBITS */ + # define XSETOBJ(var, vartype, value) do { \ - Lisp_Object *_xzx = &(var); \ - _xzx->gu.val = (EMACS_UINT) (value); \ - _xzx->gu.type = (vartype); \ - _xzx->gu.markbit = 0; \ + EMACS_UINT xset_value = (EMACS_UINT) (value); \ + Lisp_Object *xset_var = &(var); \ + xset_var->gu.type = (vartype); \ + xset_var->gu.markbit = 0; \ + xset_var->gu.val = xset_value; \ } while (0) # define XSETINT(var, value) XSETOBJ (var, Lisp_Type_Int, value) # define XSETCHAR(var, value) XSETOBJ (var, Lisp_Type_Char, value) # define XPNTRVAL(x) ((x).gu.val) + #endif /* ! USE_MINIMAL_TAGBITS */ INLINE Lisp_Object make_int (EMACS_INT val); diff --git a/src/lisp.h b/src/lisp.h index 232f48a..c820d52 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -26,7 +26,7 @@ Boston, MA 02111-1307, USA. */ #define _XEMACS_LISP_H_ /************************************************************************/ -/* general definitions */ +/* general definitions */ /************************************************************************/ /* We include the following generally useful header files so that you @@ -181,7 +181,7 @@ void xfree (void *); # define DOESNT_RETURN void volatile # define DECLARE_DOESNT_RETURN(decl) \ extern void volatile decl __attribute__ ((noreturn)) -# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \ +# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \ /* Should be able to state multiple independent __attribute__s, but \ the losing syntax doesn't work that way, and screws losing cpp */ \ extern void volatile decl \ @@ -189,13 +189,13 @@ void xfree (void *); # else # define DOESNT_RETURN void volatile # define DECLARE_DOESNT_RETURN(decl) extern void volatile decl -# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \ +# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \ extern void volatile decl PRINTF_ARGS(str,idx) # endif /* GNUC 2.5 */ # else # define DOESNT_RETURN void # define DECLARE_DOESNT_RETURN(decl) extern void decl -# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \ +# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \ extern void decl PRINTF_ARGS(str,idx) # endif /* GNUC */ #endif @@ -215,15 +215,6 @@ void xfree (void *); #define ALIGN_PTR(ptr, unit) \ ((void *) ALIGN_SIZE ((long) (ptr), unit)) -#ifdef QUANTIFY -#include "quantify.h" -#define QUANTIFY_START_RECORDING quantify_start_recording_data () -#define QUANTIFY_STOP_RECORDING quantify_stop_recording_data () -#else /* !QUANTIFY */ -#define QUANTIFY_START_RECORDING -#define QUANTIFY_STOP_RECORDING -#endif /* !QUANTIFY */ - #ifndef DO_NOTHING #define DO_NOTHING do {} while (0) #endif @@ -260,7 +251,7 @@ DECLARE_DOESNT_RETURN (assert_failed (CONST char *, int, CONST char *)); /************************************************************************/ -/* typedefs */ +/* typedefs */ /************************************************************************/ /* We put typedefs here so that prototype declarations don't choke. @@ -333,12 +324,18 @@ typedef struct extent *EXTENT; struct frame; /* "frame.h" */ struct window; /* "window.h" */ struct Lisp_Event; /* "events.h" */ +typedef struct Lisp_Event Lisp_Event; struct Lisp_Face; +typedef struct Lisp_Face Lisp_Face; struct Lisp_Process; /* "process.c" */ +typedef struct Lisp_Process Lisp_Process; struct stat; /* */ struct Lisp_Color_Instance; +typedef struct Lisp_Color_Instance Lisp_Color_Instance; struct Lisp_Font_Instance; +typedef struct Lisp_Font_Instance Lisp_Font_Instance; struct Lisp_Image_Instance; +typedef struct Lisp_Image_Instance Lisp_Image_Instance; struct display_line; struct redisplay_info; struct window_mirror; @@ -506,7 +503,7 @@ enum munge_me_out_the_door /************************************************************************/ -/* Definition of Lisp_Object data type */ +/* Definition of Lisp_Object data type */ /************************************************************************/ #ifdef USE_MINIMAL_TAGBITS @@ -524,14 +521,14 @@ enum munge_me_out_the_door enum Lisp_Type { - /* Integer. XINT(obj) is the integer value. */ - Lisp_Type_Int, - /* XRECORD_LHEADER (object) points to a struct lrecord_header - lheader->implementation determines the type (and GC behaviour) + lheader->implementation determines the type (and GC behavior) of the object. */ Lisp_Type_Record, + /* Integer. XINT(obj) is the integer value. */ + Lisp_Type_Int, + #ifndef LRECORD_CONS /* Cons. XCONS (object) points to a struct Lisp_Cons. */ Lisp_Type_Cons, @@ -574,22 +571,28 @@ enum Lisp_Type #endif /* USE_MINIMAL_TAGBITS */ -/* This should be the underlying type into which a Lisp_Object must fit. - In a strict ANSI world, this must be `int', since ANSI says you can't - use bitfields on any type other than `int'. However, on a machine - where `int' and `long' are not the same size, this should be the - longer of the two. (This also must be something into which a pointer - to an arbitrary object will fit, modulo any DATA_SEG_BITS cruft.) - */ -/* ### We should be using uintptr_t and SIZEOF_VOID_P here */ -#if (LONGBITS > INTBITS) -# define EMACS_INT long -# define EMACS_UINT unsigned long -# define SIZEOF_EMACS_INT SIZEOF_LONG -#else -# define EMACS_INT int -# define EMACS_UINT unsigned int -# define SIZEOF_EMACS_INT SIZEOF_INT +/* EMACS_INT is the underlying integral type into which a Lisp_Object must fit. + In particular, it must be large enough to contain a pointer. + config.h can override this, e.g. to use `long long' for bigger lisp ints. */ + +#ifndef SIZEOF_EMACS_INT +# define SIZEOF_EMACS_INT SIZEOF_VOID_P +#endif + +#ifndef EMACS_INT +# if SIZEOF_EMACS_INT == SIZEOF_LONG +# define EMACS_INT long +# elif SIZEOF_EMACS_INT == SIZEOF_INT +# define EMACS_INT int +# elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG +# define EMACS_INT long long +# else +# error Unable to determine suitable type for EMACS_INT +# endif +#endif + +#ifndef EMACS_UINT +# define EMACS_UINT unsigned EMACS_INT #endif #define BITS_PER_EMACS_INT (SIZEOF_EMACS_INT * BITS_PER_CHAR) @@ -669,12 +672,12 @@ int eq_with_ebola_notice (Lisp_Object, Lisp_Object); /************************************************************************/ -/* Definitions of basic Lisp objects */ +/* Definitions of basic Lisp objects */ /************************************************************************/ #include "lrecord.h" -/********** unbound ***********/ +/*********** unbound ***********/ /* Qunbound is a special Lisp_Object (actually of type symbol-value-forward), that can never be visible to @@ -695,6 +698,7 @@ struct Lisp_Cons #endif Lisp_Object car, cdr; }; +typedef struct Lisp_Cons Lisp_Cons; #if 0 /* FSFmacs */ /* Like a cons, but records info on where the text lives that it was read from */ @@ -710,8 +714,8 @@ struct Lisp_Buffer_Cons #ifdef LRECORD_CONS -DECLARE_LRECORD (cons, struct Lisp_Cons); -#define XCONS(x) XRECORD (x, cons, struct Lisp_Cons) +DECLARE_LRECORD (cons, Lisp_Cons); +#define XCONS(x) XRECORD (x, cons, Lisp_Cons) #define XSETCONS(x, p) XSETRECORD (x, p, cons) #define CONSP(x) RECORDP (x, cons) #define GC_CONSP(x) GC_RECORDP (x, cons) @@ -723,8 +727,8 @@ DECLARE_LRECORD (cons, struct Lisp_Cons); #else /* ! LRECORD_CONS */ -DECLARE_NONRECORD (cons, Lisp_Type_Cons, struct Lisp_Cons); -#define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, struct Lisp_Cons) +DECLARE_NONRECORD (cons, Lisp_Type_Cons, Lisp_Cons); +#define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, Lisp_Cons) #define XSETCONS(c, p) XSETOBJ (c, Lisp_Type_Cons, p) #define CONSP(x) (XTYPE (x) == Lisp_Type_Cons) #define GC_CONSP(x) (XGCTYPE (x) == Lisp_Type_Cons) @@ -738,6 +742,8 @@ DECLARE_NONRECORD (cons, Lisp_Type_Cons, struct Lisp_Cons); #endif /* ! LRECORD_CONS */ +extern Lisp_Object Qnil; + #define NILP(x) EQ (x, Qnil) #define GC_NILP(x) GC_EQ (x, Qnil) #define XCAR(a) (XCONS (a)->car) @@ -756,78 +762,312 @@ DECLARE_NONRECORD (cons, Lisp_Type_Cons, struct Lisp_Cons); /* For a list that's known to be in valid list format -- will abort() if the list is not in valid format */ -#define LIST_LOOP(consvar, list) \ - for (consvar = list; !NILP (consvar); consvar = XCDR (consvar)) +#define LIST_LOOP(tail, list) \ + for (tail = list; \ + !NILP (tail); \ + tail = XCDR (tail)) + +#define LIST_LOOP_2(elt, list) \ + Lisp_Object tail##elt; \ + LIST_LOOP_3(elt, list, tail##elt) + +#define LIST_LOOP_3(elt, list, tail) \ + for (tail = list; \ + NILP (tail) ? \ + 0 : (elt = XCAR (tail), 1); \ + tail = XCDR (tail)) + +#define GET_LIST_LENGTH(list, len) do { \ + Lisp_Object GLL_tail; \ + for (GLL_tail = list, len = 0; \ + !NILP (GLL_tail); \ + GLL_tail = XCDR (GLL_tail), ++len) \ + DO_NOTHING; \ +} while (0) + +#define GET_EXTERNAL_LIST_LENGTH(list, len) \ +do { \ + Lisp_Object GELL_elt, GELL_tail; \ + EXTERNAL_LIST_LOOP_4 (GELL_elt, list, GELL_tail, len) \ + ; \ +} while (0) /* For a list that's known to be in valid list format, where we may be deleting the current element out of the list -- will abort() if the list is not in valid format */ -#define LIST_LOOP_DELETING(consvar, nextconsvar, list) \ - for (consvar = list; \ - !NILP (consvar) ? (nextconsvar = XCDR (consvar), 1) : 0; \ +#define LIST_LOOP_DELETING(consvar, nextconsvar, list) \ + for (consvar = list; \ + !NILP (consvar) ? (nextconsvar = XCDR (consvar), 1) :0; \ consvar = nextconsvar) +/* Delete all elements of external list LIST + satisfying CONDITION, an expression referring to variable ELT */ +#define EXTERNAL_LIST_LOOP_DELETE_IF(elt, list, condition) do { \ + Lisp_Object prev_tail_##list = Qnil; \ + Lisp_Object tail_##list; \ + int len_##list; \ + EXTERNAL_LIST_LOOP_4 (elt, list, tail_##list, len_##list) \ + { \ + if (condition) \ + { \ + if (NILP (prev_tail_##list)) \ + list = XCDR (tail_##list); \ + else \ + XCDR (prev_tail_##list) = XCDR (tail_##list); \ + /* Keep tortoise from ever passing hare. */ \ + len_##list = 0; \ + } \ + else \ + prev_tail_##list = tail_##list; \ + } \ +} while (0) + +/* Delete all elements of true non-circular list LIST + satisfying CONDITION, an expression referring to variable ELT */ +#define LIST_LOOP_DELETE_IF(elt, list, condition) do { \ + Lisp_Object prev_tail_##list = Qnil; \ + Lisp_Object tail_##list; \ + LIST_LOOP_3 (elt, list, tail_##list) \ + { \ + if (condition) \ + { \ + if (NILP (prev_tail_##list)) \ + list = XCDR (tail_##list); \ + else \ + XCDR (prev_tail_##list) = XCDR (tail_##list); \ + } \ + else \ + prev_tail_##list = tail_##list; \ + } \ +} while (0) + /* For a list that may not be in valid list format -- will signal an error if the list is not in valid format */ -#define EXTERNAL_LIST_LOOP(consvar, listp) \ - for (consvar = listp; !NILP (consvar); consvar = XCDR (consvar)) \ - if (!CONSP (consvar)) \ - signal_simple_error ("Invalid list format", listp); \ +#define EXTERNAL_LIST_LOOP(tail, list) \ + for (tail = list; !NILP (tail); tail = XCDR (tail)) \ + if (!CONSP (tail)) \ + signal_malformed_list_error (list); \ else -extern Lisp_Object Qnil; -INLINE int TRUE_LIST_P (Lisp_Object object); -INLINE int -TRUE_LIST_P (Lisp_Object object) -{ - while (CONSP (object)) - object = XCDR (object); - return NILP (object); -} +/* The following macros are for traversing lisp lists. + Signal an error if LIST is not properly acyclic and nil-terminated. + + Use tortoise/hare algorithm to check for cycles, but only if it + looks like the list is getting too long. Not only is the hare + faster than the tortoise; it even gets a head start! */ + +/* Optimized and safe macros for looping over external lists. */ +#define CIRCULAR_LIST_SUSPICION_LENGTH 1024 + +#define EXTERNAL_LIST_LOOP_1(list) \ +Lisp_Object ELL1_elt, ELL1_hare, ELL1_tortoise; \ +int ELL1_len; \ +EXTERNAL_LIST_LOOP_6(ELL1_elt, list, ELL1_len, ELL1_hare, \ + ELL1_tortoise, CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_LIST_LOOP_2(elt, list) \ +Lisp_Object hare_##elt, tortoise_##elt; \ +int len_##elt; \ +EXTERNAL_LIST_LOOP_6(elt, list, len_##elt, hare_##elt, \ + tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_LIST_LOOP_3(elt, list, tail) \ +Lisp_Object tortoise_##elt; \ +int len_##elt; \ +EXTERNAL_LIST_LOOP_6(elt, list, len_##elt, tail, \ + tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_LIST_LOOP_4(elt, list, tail, len) \ +Lisp_Object tortoise_##elt; \ +EXTERNAL_LIST_LOOP_6(elt, list, len, tail, \ + tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH) + + +#define EXTERNAL_LIST_LOOP_6(elt, list, len, hare, \ + tortoise, suspicion_length) \ + for (tortoise = hare = list, len = 0; \ + \ + (CONSP (hare) ? ((elt = XCAR (hare)), 1) : \ + (NILP (hare) ? 0 : \ + (signal_malformed_list_error (list), 0))); \ + \ + hare = XCDR (hare), \ + ((++len < suspicion_length) ? \ + ((void) 0) : \ + (((len & 1) ? \ + ((void) (tortoise = XCDR (tortoise))) : \ + ((void) 0)) \ + , \ + (EQ (hare, tortoise) ? \ + ((void) signal_circular_list_error (list)) : \ + ((void) 0))))) + + + +/* Optimized and safe macros for looping over external alists. */ +#define EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, list) \ +Lisp_Object hare_##elt, tortoise_##elt; \ +int len_##elt; \ +EXTERNAL_ALIST_LOOP_8 (elt, elt_car, elt_cdr, list, \ + len_##elt, hare_##elt, tortoise_##elt, \ + CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_ALIST_LOOP_5(elt, elt_car, elt_cdr, list, tail) \ +Lisp_Object tortoise_##elt; \ +int len_##elt; \ +EXTERNAL_ALIST_LOOP_8(elt, elt_car, elt_cdr, list, \ + len_##elt, tail, tortoise_##elt, \ + CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_ALIST_LOOP_6(elt, elt_car, elt_cdr, list, tail, len) \ +Lisp_Object tortoise_##elt; \ +EXTERNAL_ALIST_LOOP_8(elt, elt_car, elt_cdr, list, \ + len, tail, tortoise_##elt, \ + CIRCULAR_LIST_SUSPICION_LENGTH) + + +#define EXTERNAL_ALIST_LOOP_8(elt, elt_car, elt_cdr, list, len, hare, \ + tortoise, suspicion_length) \ +EXTERNAL_LIST_LOOP_6(elt, list, len, hare, tortoise, suspicion_length) \ + if (CONSP (elt) ? (elt_car = XCAR (elt), elt_cdr = XCDR (elt), 0) :1) \ + continue; \ + else -#define CHECK_TRUE_LIST(object) do { \ - if (!TRUE_LIST_P (object)) \ - dead_wrong_type_argument (Qtrue_list_p, object); \ -} while (0) + +/* Optimized and safe macros for looping over external property lists. */ +#define EXTERNAL_PROPERTY_LIST_LOOP_3(key, value, list) \ +Lisp_Object key, value, hare_##key, tortoise_##key; \ +int len_##key; \ +EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len_##key, hare_##key,\ + tortoise_##key, CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_PROPERTY_LIST_LOOP_4(key, value, list, tail) \ +Lisp_Object key, value, tail, tortoise_##key; \ +int len_##key; \ +EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len_##key, tail, \ + tortoise_##key, CIRCULAR_LIST_SUSPICION_LENGTH) + +#define EXTERNAL_PROPERTY_LIST_LOOP_5(key, value, list, tail, len) \ +Lisp_Object key, value, tail, tortoise_##key; \ +int len; \ +EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len, tail, \ + tortoise_##key, CIRCULAR_LIST_SUSPICION_LENGTH) + + +#define EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len, hare, \ + tortoise, suspicion_length) \ + for (tortoise = hare = list, len = 0; \ + \ + ((CONSP (hare) && \ + (key = XCAR (hare), \ + hare = XCDR (hare), \ + CONSP (hare))) ? \ + (value = XCAR (hare), 1) : \ + (NILP (hare) ? 0 : \ + (signal_malformed_property_list_error (list), 0))); \ + \ + hare = XCDR (hare), \ + ((++len < suspicion_length) ? \ + ((void) 0) : \ + (((len & 1) ? \ + ((void) (tortoise = XCDR (XCDR (tortoise)))) : \ + ((void) 0)) \ + , \ + (EQ (hare, tortoise) ? \ + ((void) signal_circular_property_list_error (list)) : \ + ((void) 0))))) /* For a property list (alternating keywords/values) that may not be in valid list format -- will signal an error if the list is not in valid format. CONSVAR is used to keep track of the iterations - without modifying LISTP. + without modifying PLIST. We have to be tricky to still keep the same C format.*/ -#define EXTERNAL_PROPERTY_LIST_LOOP(consvar, keyword, value, listp) \ - for (consvar = listp; \ - (CONSP (consvar) && CONSP (XCDR (consvar)) ? \ - (keyword = XCAR (consvar), value = XCAR (XCDR (consvar))) : \ - (keyword = Qunbound, value = Qunbound)), \ - !NILP (consvar); \ - consvar = XCDR (XCDR (consvar))) \ - if (UNBOUNDP (keyword)) \ - signal_simple_error ("Invalid property list format", listp); \ +#define EXTERNAL_PROPERTY_LIST_LOOP(tail, key, value, plist) \ + for (tail = plist; \ + (CONSP (tail) && CONSP (XCDR (tail)) ? \ + (key = XCAR (tail), value = XCAR (XCDR (tail))) : \ + (key = Qunbound, value = Qunbound)), \ + !NILP (tail); \ + tail = XCDR (XCDR (tail))) \ + if (UNBOUNDP (key)) \ + Fsignal (Qmalformed_property_list, list1 (plist)); \ else +#define PROPERTY_LIST_LOOP(tail, key, value, plist) \ + for (tail = plist; \ + NILP (tail) ? 0 : \ + (key = XCAR (tail), tail = XCDR (tail), \ + value = XCAR (tail), tail = XCDR (tail), 1); \ + ) + +/* Return 1 if LIST is properly acyclic and nil-terminated, else 0. */ +INLINE int TRUE_LIST_P (Lisp_Object object); +INLINE int +TRUE_LIST_P (Lisp_Object object) +{ + Lisp_Object hare, tortoise; + int len; + + for (hare = tortoise = object, len = 0; + CONSP (hare); + hare = XCDR (hare), len++) + { + if (len < CIRCULAR_LIST_SUSPICION_LENGTH) + continue; + + if (len & 1) + tortoise = XCDR (tortoise); + else if (EQ (hare, tortoise)) + return 0; + } + + return NILP (hare); +} + +/* Signal an error if LIST is not properly acyclic and nil-terminated. */ +#define CHECK_TRUE_LIST(list) do { \ + Lisp_Object CTL_list = (list); \ + Lisp_Object CTL_hare, CTL_tortoise; \ + int CTL_len; \ + \ + for (CTL_hare = CTL_tortoise = CTL_list, CTL_len = 0; \ + CONSP (CTL_hare); \ + CTL_hare = XCDR (CTL_hare), CTL_len++) \ + { \ + if (CTL_len < CIRCULAR_LIST_SUSPICION_LENGTH) \ + continue; \ + \ + if (CTL_len & 1) \ + CTL_tortoise = XCDR (CTL_tortoise); \ + else if (EQ (CTL_hare, CTL_tortoise)) \ + Fsignal (Qcircular_list, list1 (CTL_list)); \ + } \ + \ + if (! NILP (CTL_hare)) \ + signal_malformed_list_error (CTL_list); \ +} while (0) + /*********** string ***********/ -/* In a string or vector, the sign bit of the `size' is the gc mark bit */ +/* In a string, the markbit of the plist is used as the gc mark bit */ -/* (The size and data fields have underscores prepended to catch old - code that attempts to reference the fields directly) */ struct Lisp_String { #ifdef LRECORD_STRING struct lrecord_header lheader; #endif - Bytecount _size; - Bufbyte *_data; + Bytecount size; + Bufbyte *data; Lisp_Object plist; }; +typedef struct Lisp_String Lisp_String; #ifdef LRECORD_STRING -DECLARE_LRECORD (string, struct Lisp_String); -#define XSTRING(x) XRECORD (x, string, struct Lisp_String) +DECLARE_LRECORD (string, Lisp_String); +#define XSTRING(x) XRECORD (x, string, Lisp_String) #define XSETSTRING(x, p) XSETRECORD (x, p, string) #define STRINGP(x) RECORDP (x, string) #define GC_STRINGP(x) GC_RECORDP (x, string) @@ -836,8 +1076,8 @@ DECLARE_LRECORD (string, struct Lisp_String); #else /* ! LRECORD_STRING */ -DECLARE_NONRECORD (string, Lisp_Type_String, struct Lisp_String); -#define XSTRING(x) XNONRECORD (x, string, Lisp_Type_String, struct Lisp_String) +DECLARE_NONRECORD (string, Lisp_Type_String, Lisp_String); +#define XSTRING(x) XNONRECORD (x, string, Lisp_Type_String, Lisp_String) #define XSETSTRING(x, p) XSETOBJ (x, Lisp_Type_String, p) #define STRINGP(x) (XTYPE (x) == Lisp_Type_String) #define GC_STRINGP(x) (XGCTYPE (x) == Lisp_Type_String) @@ -858,32 +1098,32 @@ Bytecount charcount_to_bytecount (CONST Bufbyte *ptr, Charcount len); #endif /* not MULE */ -#define string_length(s) ((s)->_size) +#define string_length(s) ((s)->size) #define XSTRING_LENGTH(s) string_length (XSTRING (s)) #define XSTRING_CHAR_LENGTH(s) string_char_length (XSTRING (s)) -#define string_data(s) ((s)->_data + 0) +#define string_data(s) ((s)->data + 0) #define XSTRING_DATA(s) string_data (XSTRING (s)) -#define string_byte(s, i) ((s)->_data[i] + 0) +#define string_byte(s, i) ((s)->data[i] + 0) #define XSTRING_BYTE(s, i) string_byte (XSTRING (s), i) -#define string_byte_addr(s, i) (&((s)->_data[i])) -#define set_string_length(s, len) ((void) ((s)->_size = (len))) -#define set_string_data(s, ptr) ((void) ((s)->_data = (ptr))) -#define set_string_byte(s, i, c) ((void) ((s)->_data[i] = (c))) +#define string_byte_addr(s, i) (&((s)->data[i])) +#define set_string_length(s, len) ((void) ((s)->size = (len))) +#define set_string_data(s, ptr) ((void) ((s)->data = (ptr))) +#define set_string_byte(s, i, c) ((void) ((s)->data[i] = (c))) -void resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta); +void resize_string (Lisp_String *s, Bytecount pos, Bytecount delta); #ifdef MULE -INLINE Charcount string_char_length (struct Lisp_String *s); +INLINE Charcount string_char_length (Lisp_String *s); INLINE Charcount -string_char_length (struct Lisp_String *s) +string_char_length (Lisp_String *s) { return bytecount_to_charcount (string_data (s), string_length (s)); } # define string_char(s, i) charptr_emchar_n (string_data (s), i) # define string_char_addr(s, i) charptr_n_addr (string_data (s), i) -void set_string_char (struct Lisp_String *s, Charcount i, Emchar c); +void set_string_char (Lisp_String *s, Charcount i, Emchar c); #else /* not MULE */ @@ -907,11 +1147,12 @@ struct Lisp_Vector /* struct Lisp_Vector *next; */ Lisp_Object contents[1]; }; +typedef struct Lisp_Vector Lisp_Vector; #ifdef LRECORD_VECTOR -DECLARE_LRECORD (vector, struct Lisp_Vector); -#define XVECTOR(x) XRECORD (x, vector, struct Lisp_Vector) +DECLARE_LRECORD (vector, Lisp_Vector); +#define XVECTOR(x) XRECORD (x, vector, Lisp_Vector) #define XSETVECTOR(x, p) XSETRECORD (x, p, vector) #define VECTORP(x) RECORDP (x, vector) #define GC_VECTORP(x) GC_RECORDP (x, vector) @@ -920,8 +1161,8 @@ DECLARE_LRECORD (vector, struct Lisp_Vector); #else -DECLARE_NONRECORD (vector, Lisp_Type_Vector, struct Lisp_Vector); -#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Type_Vector, struct Lisp_Vector) +DECLARE_NONRECORD (vector, Lisp_Type_Vector, Lisp_Vector); +#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Type_Vector, Lisp_Vector) #define XSETVECTOR(x, p) XSETOBJ (x, Lisp_Type_Vector, p) #define VECTORP(x) (XTYPE (x) == Lisp_Type_Vector) #define GC_VECTORP(x) (XGCTYPE (x) == Lisp_Type_Vector) @@ -959,12 +1200,13 @@ struct Lisp_Bit_Vector { struct lrecord_header lheader; Lisp_Object next; - long size; + size_t size; unsigned long bits[1]; }; +typedef struct Lisp_Bit_Vector Lisp_Bit_Vector; -DECLARE_LRECORD (bit_vector, struct Lisp_Bit_Vector); -#define XBIT_VECTOR(x) XRECORD (x, bit_vector, struct Lisp_Bit_Vector) +DECLARE_LRECORD (bit_vector, Lisp_Bit_Vector); +#define XBIT_VECTOR(x) XRECORD (x, bit_vector, Lisp_Bit_Vector) #define XSETBIT_VECTOR(x, p) XSETRECORD (x, p, bit_vector) #define BIT_VECTORP(x) RECORDP (x, bit_vector) #define GC_BIT_VECTORP(x) GC_RECORDP (x, bit_vector) @@ -987,9 +1229,9 @@ DECLARE_LRECORD (bit_vector, struct Lisp_Bit_Vector); #define bit_vector_length(v) ((v)->size) #define bit_vector_next(v) ((v)->next) -INLINE int bit_vector_bit (struct Lisp_Bit_Vector *v, int i); +INLINE int bit_vector_bit (Lisp_Bit_Vector *v, int i); INLINE int -bit_vector_bit (struct Lisp_Bit_Vector *v, int i) +bit_vector_bit (Lisp_Bit_Vector *v, int i) { unsigned int ui = (unsigned int) i; @@ -997,15 +1239,15 @@ bit_vector_bit (struct Lisp_Bit_Vector *v, int i) & 1); } -INLINE void set_bit_vector_bit (struct Lisp_Bit_Vector *v, int i, int value); +INLINE void set_bit_vector_bit (Lisp_Bit_Vector *v, int i, int value); INLINE void -set_bit_vector_bit (struct Lisp_Bit_Vector *v, int i, int value) +set_bit_vector_bit (Lisp_Bit_Vector *v, int i, int value) { unsigned int ui = (unsigned int) i; if (value) - (v)->bits[ui >> LONGBITS_LOG2] |= (1 << (ui & (LONGBITS_POWER_OF_2 - 1))); + (v)->bits[ui >> LONGBITS_LOG2] |= (1U << (ui & (LONGBITS_POWER_OF_2 - 1))); else - (v)->bits[ui >> LONGBITS_LOG2] &= ~(1 << (ui & (LONGBITS_POWER_OF_2 - 1))); + (v)->bits[ui >> LONGBITS_LOG2] &= ~(1U << (ui & (LONGBITS_POWER_OF_2 - 1))); } /* Number of longs required to hold LEN bits */ @@ -1031,14 +1273,15 @@ struct Lisp_Symbol Lisp_Object obarray; Lisp_Object plist; }; +typedef struct Lisp_Symbol Lisp_Symbol; #define SYMBOL_IS_KEYWORD(sym) (string_byte (XSYMBOL(sym)->name, 0) == ':') #define KEYWORDP(obj) (SYMBOLP (obj) && SYMBOL_IS_KEYWORD (obj)) #ifdef LRECORD_SYMBOL -DECLARE_LRECORD (symbol, struct Lisp_Symbol); -#define XSYMBOL(x) XRECORD (x, symbol, struct Lisp_Symbol) +DECLARE_LRECORD (symbol, Lisp_Symbol); +#define XSYMBOL(x) XRECORD (x, symbol, Lisp_Symbol) #define XSETSYMBOL(x, p) XSETRECORD (x, p, symbol) #define SYMBOLP(x) RECORDP (x, symbol) #define GC_SYMBOLP(x) GC_RECORDP (x, symbol) @@ -1047,8 +1290,8 @@ DECLARE_LRECORD (symbol, struct Lisp_Symbol); #else -DECLARE_NONRECORD (symbol, Lisp_Type_Symbol, struct Lisp_Symbol); -#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Type_Symbol, struct Lisp_Symbol) +DECLARE_NONRECORD (symbol, Lisp_Type_Symbol, Lisp_Symbol); +#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Type_Symbol, Lisp_Symbol) #define XSETSYMBOL(s, p) XSETOBJ ((s), Lisp_Type_Symbol, (p)) #define SYMBOLP(x) (XTYPE (x) == Lisp_Type_Symbol) #define GC_SYMBOLP(x) (XGCTYPE (x) == Lisp_Type_Symbol) @@ -1076,9 +1319,10 @@ struct Lisp_Subr CONST char *name; lisp_fn_t subr_fn; }; +typedef struct Lisp_Subr Lisp_Subr; -DECLARE_LRECORD (subr, struct Lisp_Subr); -#define XSUBR(x) XRECORD (x, subr, struct Lisp_Subr) +DECLARE_LRECORD (subr, Lisp_Subr); +#define XSUBR(x) XRECORD (x, subr, Lisp_Subr) #define XSETSUBR(x, p) XSETRECORD (x, p, subr) #define SUBRP(x) RECORDP (x, subr) #define GC_SUBRP(x) GC_RECORDP (x, subr) @@ -1098,9 +1342,10 @@ struct Lisp_Marker Memind memind; char insertion_type; }; +typedef struct Lisp_Marker Lisp_Marker; -DECLARE_LRECORD (marker, struct Lisp_Marker); -#define XMARKER(x) XRECORD (x, marker, struct Lisp_Marker) +DECLARE_LRECORD (marker, Lisp_Marker); +#define XMARKER(x) XRECORD (x, marker, Lisp_Marker) #define XSETMARKER(x, p) XSETRECORD (x, p, marker) #define MARKERP(x) RECORDP (x, marker) #define GC_MARKERP(x) GC_RECORDP (x, marker) @@ -1142,7 +1387,7 @@ XCHAR (Lisp_Object obj) #ifdef LISP_FLOAT_TYPE -/* Note: the 'unused__next__' field exists only to ensure that the +/* Note: the 'unused_next_' field exists only to ensure that the `next' pointer fits within the structure, for the purposes of the free list. This makes a difference in the unlikely case of sizeof(double) being smaller than sizeof(void *). */ @@ -1150,11 +1395,12 @@ XCHAR (Lisp_Object obj) struct Lisp_Float { struct lrecord_header lheader; - union { double d; struct Lisp_Float *unused__next__; } data; + union { double d; struct Lisp_Float *unused_next_; } data; }; +typedef struct Lisp_Float Lisp_Float; -DECLARE_LRECORD (float, struct Lisp_Float); -#define XFLOAT(x) XRECORD (x, float, struct Lisp_Float) +DECLARE_LRECORD (float, Lisp_Float); +#define XFLOAT(x) XRECORD (x, float, Lisp_Float) #define XSETFLOAT(x, p) XSETRECORD (x, p, float) #define FLOATP(x) RECORDP (x, float) #define GC_FLOATP(x) GC_RECORDP (x, float) @@ -1162,6 +1408,7 @@ DECLARE_LRECORD (float, struct Lisp_Float); #define CONCHECK_FLOAT(x) CONCHECK_RECORD (x, float) #define float_data(f) ((f)->data.d) +#define XFLOAT_DATA(x) float_data (XFLOAT (x)) #define XFLOATINT(n) extract_float (n) @@ -1175,29 +1422,6 @@ DECLARE_LRECORD (float, struct Lisp_Float); x = wrong_type_argument (Qnumberp, x); \ } while (0) -/* These are always continuable because they change their arguments - even when no error is signalled. */ - -#define CHECK_INT_OR_FLOAT_COERCE_MARKER(x) do { \ - if (INT_OR_FLOATP (x)) \ - ; \ - else if (MARKERP (x)) \ - x = make_int (marker_position (x)); \ - else \ - x = wrong_type_argument (Qnumber_or_marker_p, x); \ -} while (0) - -#define CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER(x) do { \ - if (INT_OR_FLOATP (x)) \ - ; \ - else if (CHARP (x)) \ - x = make_int (XCHAR (x)); \ - else if (MARKERP (x)) \ - x = make_int (marker_position (x)); \ - else \ - x = wrong_type_argument (Qnumber_char_or_marker_p, x); \ -} while (0) - # define INT_OR_FLOATP(x) (INTP (x) || FLOATP (x)) # define GC_INT_OR_FLOATP(x) (GC_INTP (x) || GC_FLOATP (x)) @@ -1213,9 +1437,6 @@ DECLARE_LRECORD (float, struct Lisp_Float); #define XFLOATINT(n) XINT(n) #define CHECK_INT_OR_FLOAT CHECK_INT #define CONCHECK_INT_OR_FLOAT CONCHECK_INT -#define CHECK_INT_OR_FLOAT_COERCE_MARKER CHECK_INT_COERCE_MARKER -#define CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER \ - CHECK_INT_COERCE_CHAR_OR_MARKER #define INT_OR_FLOATP(x) (INTP (x)) # define GC_INT_OR_FLOATP(x) (GC_INTP (x)) @@ -1306,6 +1527,7 @@ XCHAR_OR_INT (Lisp_Object obj) x = wrong_type_argument (Qinteger_char_or_marker_p, x); \ } while (0) + /*********** pure space ***********/ #define CHECK_IMPURE(obj) \ @@ -1419,7 +1641,7 @@ void free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord); /************************************************************************/ -/* Definitions of primitive Lisp functions and variables */ +/* Definitions of primitive Lisp functions and variables */ /************************************************************************/ @@ -1430,8 +1652,8 @@ void free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord); valid in a C identifier, with an "F" prepended. The name of the C constant structure that records information on this function for internal use is "S" concatenated with Fname. - `minargs' should be a number, the minimum number of arguments allowed. - `maxargs' should be a number, the maximum number of arguments allowed, + `min_args' should be a number, the minimum number of arguments allowed. + `max_args' should be a number, the maximum number of arguments allowed, or else MANY or UNEVALLED. MANY means pass a vector of evaluated arguments, in the form of an integer number-of-arguments @@ -1462,7 +1684,7 @@ Lisp_Object,Lisp_Object Lisp_Object,Lisp_Object,Lisp_Object #define EXFUN_MANY int, Lisp_Object* #define EXFUN_UNEVALLED Lisp_Object -#define EXFUN(sym, maxargs) Lisp_Object sym (EXFUN_##maxargs) +#define EXFUN(sym, max_args) Lisp_Object sym (EXFUN_##max_args) #define SUBR_MAX_ARGS 8 #define MANY -2 @@ -1477,14 +1699,14 @@ Lisp_Object,Lisp_Object,Lisp_Object # define subr_lheader_initializer { lrecord_subr } #endif -#define DEFUN(lname, Fname, minargs, maxargs, prompt, arglist) \ - Lisp_Object Fname (EXFUN_##maxargs); \ +#define DEFUN(lname, Fname, min_args, max_args, prompt, arglist) \ + Lisp_Object Fname (EXFUN_##max_args); \ static struct Lisp_Subr S##Fname = { subr_lheader_initializer, \ - minargs, maxargs, prompt, 0, lname, (lisp_fn_t) Fname }; \ - Lisp_Object Fname (DEFUN_##maxargs arglist) + min_args, max_args, prompt, 0, lname, (lisp_fn_t) Fname }; \ + Lisp_Object Fname (DEFUN_##max_args arglist) /* Heavy ANSI C preprocessor hackery to get DEFUN to declare a - prototype that matches maxargs, and add the obligatory + prototype that matches max_args, and add the obligatory `Lisp_Object' type declaration to the formal C arguments. */ #define DEFUN_MANY(named_int, named_Lisp_Object) named_int, named_Lisp_Object @@ -1499,18 +1721,27 @@ Lisp_Object,Lisp_Object,Lisp_Object #define DEFUN_7(a,b,c,d,e,f,g) DEFUN_6(a,b,c,d,e,f), Lisp_Object g #define DEFUN_8(a,b,c,d,e,f,g,h) DEFUN_7(a,b,c,d,e,f,g),Lisp_Object h -/* WARNING: If you add defines here for higher values of maxargs, - make sure to also fix the clauses in inline_funcall_fn(), +/* WARNING: If you add defines here for higher values of max_args, + make sure to also fix the clauses in PRIMITIVE_FUNCALL(), and change the define of SUBR_MAX_ARGS above. */ #include "symeval.h" -/* Depth of special binding/unwind-protect stack. Use as arg to `unbind_to' */ -int specpdl_depth (void); +/* `specpdl' is the special binding/unwind-protect stack. + + Knuth says (see the Jargon File): + At MIT, `pdl' [abbreviation for `Push Down List'] used to + be a more common synonym for `stack'. + Everywhere else `stack' seems to be the preferred term. + + specpdl_depth is the current depth of `specpdl'. + Save this for use later as arg to `unbind_to'. */ +extern int specpdl_depth_counter; +#define specpdl_depth() specpdl_depth_counter /************************************************************************/ -/* Checking for QUIT */ +/* Checking for QUIT */ /************************************************************************/ /* Asynchronous events set something_happened, and then are processed @@ -1554,7 +1785,7 @@ void signal_quit (void); /************************************************************************/ -/* hashing */ +/* hashing */ /************************************************************************/ /* #### for a 64-bit machine, we should substitute a prime just over 2^32 */ @@ -1568,8 +1799,6 @@ void signal_quit (void); #define HASH8(a,b,c,d,e,f,g,h) (GOOD_HASH * HASH7 (a,b,c,d,e,f,g) + (h)) #define HASH9(a,b,c,d,e,f,g,h,i) (GOOD_HASH * HASH8 (a,b,c,d,e,f,g,h) + (i)) -/* Enough already! */ - #define LISP_HASH(obj) ((unsigned long) LISP_TO_VOID (obj)) unsigned long string_hash (CONST void *xv); unsigned long memory_hash (CONST void *xv, size_t size); @@ -1578,7 +1807,7 @@ unsigned long internal_array_hash (Lisp_Object *arr, int size, int depth); /************************************************************************/ -/* String translation */ +/* String translation */ /************************************************************************/ #ifdef I18N3 @@ -1606,7 +1835,7 @@ char *bindtextdomain (CONST char *, CONST char *); /************************************************************************/ -/* Garbage collection / GC-protection */ +/* Garbage collection / GC-protection */ /************************************************************************/ /* number of bytes of structure consed since last GC */ @@ -1708,101 +1937,104 @@ void debug_ungcpro(char *, int, struct gcpro *); #else /* ! DEBUG_GCPRO */ -#define GCPRO1(varname) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \ - gcprolist = &gcpro1; } - -#define GCPRO2(varname1, varname2) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcprolist = &gcpro2; } - -#define GCPRO3(varname1, varname2, varname3) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \ - gcprolist = &gcpro3; } - -#define GCPRO4(varname1, varname2, varname3, varname4) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \ - gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \ - gcprolist = &gcpro4; } - -#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \ - gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \ - gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \ - gcprolist = &gcpro5; } - -#define UNGCPRO (gcprolist = gcpro1.next) - -#define NGCPRO1(varname) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname; ngcpro1.nvars = 1; \ - gcprolist = &ngcpro1; } - -#define NGCPRO2(varname1, varname2) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - gcprolist = &ngcpro2; } - -#define NGCPRO3(varname1, varname2, varname3) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \ - gcprolist = &ngcpro3; } - -#define NGCPRO4(varname1, varname2, varname3, varname4) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \ - ngcpro4.next = &ngcpro3; ngcpro4.var = &varname4; ngcpro4.nvars = 1; \ - gcprolist = &ngcpro4; } - -#define NGCPRO5(varname1, varname2, varname3, varname4, varname5) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \ - ngcpro4.next = &ngcpro3; ngcpro4.var = &varname4; ngcpro4.nvars = 1; \ - ngcpro5.next = &ngcpro4; ngcpro5.var = &varname5; ngcpro5.nvars = 1; \ - gcprolist = &ngcpro5; } - -#define NUNGCPRO (gcprolist = ngcpro1.next) - -#define NNGCPRO1(varname) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname; nngcpro1.nvars = 1; \ - gcprolist = &nngcpro1; } - -#define NNGCPRO2(varname1, varname2) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - gcprolist = &nngcpro2; } - -#define NNGCPRO3(varname1, varname2, varname3) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \ - gcprolist = &nngcpro3; } - -#define NNGCPRO4(varname1, varname2, varname3, varname4) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \ - nngcpro4.next = &nngcpro3; nngcpro4.var = &varname4; nngcpro4.nvars = 1; \ - gcprolist = &nngcpro4; } - -#define NNGCPRO5(varname1, varname2, varname3, varname4, varname5) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \ - nngcpro4.next = &nngcpro3; nngcpro4.var = &varname4; nngcpro4.nvars = 1; \ - nngcpro5.next = &nngcpro4; nngcpro5.var = &varname5; nngcpro5.nvars = 1; \ - gcprolist = &nngcpro5; } - -#define NNUNGCPRO (gcprolist = nngcpro1.next) +#define GCPRO1(var1) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcprolist = &gcpro1 )) + +#define GCPRO2(var1, var2) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcprolist = &gcpro2 )) + +#define GCPRO3(var1, var2, var3) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \ + gcprolist = &gcpro3 )) + +#define GCPRO4(var1, var2, var3, var4) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \ + gcpro4.next = &gcpro3, gcpro4.var = &var4, gcpro4.nvars = 1, \ + gcprolist = &gcpro4 )) + +#define GCPRO5(var1, var2, var3, var4, var5) \ + ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \ + gcpro4.next = &gcpro3, gcpro4.var = &var4, gcpro4.nvars = 1, \ + gcpro5.next = &gcpro4, gcpro5.var = &var5, gcpro5.nvars = 1, \ + gcprolist = &gcpro5 )) + +#define UNGCPRO ((void) (gcprolist = gcpro1.next)) + +#define NGCPRO1(var1) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + gcprolist = &ngcpro1 )) + +#define NGCPRO2(var1, var2) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + gcprolist = &ngcpro2 )) + +#define NGCPRO3(var1, var2, var3) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \ + gcprolist = &ngcpro3 )) + +#define NGCPRO4(var1, var2, var3, var4) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \ + ngcpro4.next = &ngcpro3, ngcpro4.var = &var4, ngcpro4.nvars = 1, \ + gcprolist = &ngcpro4 )) + +#define NGCPRO5(var1, var2, var3, var4, var5) \ + ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \ + ngcpro4.next = &ngcpro3, ngcpro4.var = &var4, ngcpro4.nvars = 1, \ + ngcpro5.next = &ngcpro4, ngcpro5.var = &var5, ngcpro5.nvars = 1, \ + gcprolist = &ngcpro5 )) + +#define NUNGCPRO ((void) (gcprolist = ngcpro1.next)) + +#define NNGCPRO1(var1) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + gcprolist = &nngcpro1 )) + +#define NNGCPRO2(var1, var2) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + gcprolist = &nngcpro2 )) + +#define NNGCPRO3(var1, var2, var3) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \ + gcprolist = &nngcpro3 )) + +#define NNGCPRO4(var1, var2, var3, var4) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \ + nngcpro4.next = &nngcpro3, nngcpro4.var = &var4, nngcpro4.nvars = 1, \ + gcprolist = &nngcpro4 )) + +#define NNGCPRO5(var1, var2, var3, var4, var5) \ + ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \ + nngcpro4.next = &nngcpro3, nngcpro4.var = &var4, nngcpro4.nvars = 1, \ + nngcpro5.next = &nngcpro4, nngcpro5.var = &var5, nngcpro5.nvars = 1, \ + gcprolist = &nngcpro5 )) + +#define NNUNGCPRO ((void) (gcprolist = nngcpro1.next)) #endif /* ! DEBUG_GCPRO */ @@ -1810,10 +2042,10 @@ void debug_ungcpro(char *, int, struct gcpro *); /* "end-of-loop code not reached" */ /* "statement not reached */ #ifdef __SUNPRO_C -#define RETURN__ if (1) return +#define RETURN_SANS_WARNINGS if (1) return #define RETURN_NOT_REACHED(value) #else -#define RETURN__ return +#define RETURN_SANS_WARNINGS return #define RETURN_NOT_REACHED(value) return value; #endif @@ -1822,7 +2054,7 @@ void debug_ungcpro(char *, int, struct gcpro *); { \ Lisp_Object ret_ungc_val = (expr); \ UNGCPRO; \ - RETURN__ ret_ungc_val; \ + RETURN_SANS_WARNINGS ret_ungc_val; \ } while (0) /* Evaluate expr, NUNGCPRO, UNGCPRO, and then return the value of expr. */ @@ -1831,7 +2063,7 @@ void debug_ungcpro(char *, int, struct gcpro *); Lisp_Object ret_ungc_val = (expr); \ NUNGCPRO; \ UNGCPRO; \ - RETURN__ ret_ungc_val; \ + RETURN_SANS_WARNINGS ret_ungc_val; \ } while (0) /* Evaluate expr, NNUNGCPRO, NUNGCPRO, UNGCPRO, and then return the @@ -1842,7 +2074,7 @@ void debug_ungcpro(char *, int, struct gcpro *); NNUNGCPRO; \ NUNGCPRO; \ UNGCPRO; \ - RETURN__ ret_ungc_val; \ + RETURN_SANS_WARNINGS ret_ungc_val; \ } while (0) /* Evaluate expr, return it if it's not Qunbound. */ @@ -1850,7 +2082,7 @@ void debug_ungcpro(char *, int, struct gcpro *); { \ Lisp_Object ret_nunb_val = (expr); \ if (!UNBOUNDP (ret_nunb_val)) \ - RETURN__ ret_nunb_val; \ + RETURN_SANS_WARNINGS ret_nunb_val; \ } while (0) /* Call staticpro (&var) to protect static variable `var'. */ @@ -1895,17 +2127,17 @@ struct overhead_stats #define DIRECTORY_SEP '/' #endif #ifndef IS_DIRECTORY_SEP -#define IS_DIRECTORY_SEP(_c_) ((_c_) == DIRECTORY_SEP) +#define IS_DIRECTORY_SEP(c) ((c) == DIRECTORY_SEP) #endif #ifndef IS_DEVICE_SEP #ifndef DEVICE_SEP -#define IS_DEVICE_SEP(_c_) 0 +#define IS_DEVICE_SEP(c) 0 #else -#define IS_DEVICE_SEP(_c_) ((_c_) == DEVICE_SEP) +#define IS_DEVICE_SEP(c) ((c) == DEVICE_SEP) #endif #endif #ifndef IS_ANY_SEP -#define IS_ANY_SEP(_c_) (IS_DIRECTORY_SEP (_c_)) +#define IS_ANY_SEP(c) (IS_DIRECTORY_SEP (c)) #endif #ifdef HAVE_INTTYPES_H @@ -1968,11 +2200,11 @@ Lisp_Object make_pure_pname (CONST Bufbyte *, Bytecount, int); Lisp_Object pure_cons (Lisp_Object, Lisp_Object); Lisp_Object pure_list (int, Lisp_Object *); Lisp_Object make_pure_vector (size_t, Lisp_Object); -void free_cons (struct Lisp_Cons *); +void free_cons (Lisp_Cons *); void free_list (Lisp_Object); void free_alist (Lisp_Object); void mark_conses_in_list (Lisp_Object); -void free_marker (struct Lisp_Marker *); +void free_marker (Lisp_Marker *); int object_dead_p (Lisp_Object); #ifdef MEMORY_USAGE_STATS @@ -2058,7 +2290,7 @@ Lisp_Object save_restriction_restore (Lisp_Object); Lisp_Object save_current_buffer_restore (Lisp_Object); /* Defined in emacs.c */ -DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (fatal (CONST char *, +DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (fatal (CONST char *, ...), 1, 2); int stderr_out (CONST char *, ...) PRINTF_ARGS (1, 2); int stdout_out (CONST char *, ...) PRINTF_ARGS (1, 2); @@ -2080,7 +2312,7 @@ DECLARE_DOESNT_RETURN (signal_error (Lisp_Object, Lisp_Object)); void maybe_signal_error (Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior); Lisp_Object maybe_signal_continuable_error (Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior); -DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (error (CONST char *, +DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (error (CONST char *, ...), 1, 2); void maybe_error (Lisp_Object, Error_behavior, CONST char *, ...) PRINTF_ARGS (3, 4); @@ -2093,7 +2325,7 @@ void maybe_signal_simple_error (CONST char *, Lisp_Object, Lisp_Object signal_simple_continuable_error (CONST char *, Lisp_Object); Lisp_Object maybe_signal_simple_continuable_error (CONST char *, Lisp_Object, Lisp_Object, Error_behavior); -DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (error_with_frob +DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (error_with_frob (Lisp_Object, CONST char *, ...), 2, 3); void maybe_error_with_frob (Lisp_Object, Lisp_Object, Error_behavior, @@ -2111,7 +2343,11 @@ Lisp_Object signal_simple_continuable_error_2 (CONST char *, Lisp_Object maybe_signal_simple_continuable_error_2 (CONST char *, Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior); -Lisp_Object funcall_recording_as (Lisp_Object, int, Lisp_Object *); +void signal_malformed_list_error (Lisp_Object); +void signal_malformed_property_list_error (Lisp_Object); +void signal_circular_list_error (Lisp_Object); +void signal_circular_property_list_error (Lisp_Object); +void signal_void_function_error (Lisp_Object); Lisp_Object run_hook_with_args_in_buffer (struct buffer *, int, Lisp_Object *, enum run_hooks_condition); Lisp_Object run_hook_with_args (int, Lisp_Object *, enum run_hooks_condition); @@ -2195,7 +2431,7 @@ void signal_special_Xt_user_event (Lisp_Object, Lisp_Object, Lisp_Object); /* Defined in events.c */ void clear_event_resource (void); Lisp_Object allocate_event (void); -int event_to_character (struct Lisp_Event *, int, int, int); +int event_to_character (Lisp_Event *, int, int, int); /* Defined in fileio.c */ void record_auto_save (void); @@ -2265,6 +2501,7 @@ Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object); Lisp_Object vconcat2 (Lisp_Object, Lisp_Object); Lisp_Object vconcat3 (Lisp_Object, Lisp_Object, Lisp_Object); Lisp_Object nconc2 (Lisp_Object, Lisp_Object); +Lisp_Object bytecode_nconc2 (Lisp_Object *); void check_losing_bytecode (CONST char *, Lisp_Object); /* Defined in getloadavg.c */ @@ -2354,7 +2591,7 @@ void write_string_to_stdio_stream (FILE *, struct console *, enum external_data_format); void debug_print (Lisp_Object); void debug_short_backtrace (int); -void temp_output_buffer_setup (CONST char *); +void temp_output_buffer_setup (Lisp_Object); void temp_output_buffer_show (Lisp_Object, Lisp_Object); /* NOTE: Do not call this with the data of a Lisp_String. Use princ. * Note: stream should be defaulted before calling @@ -2369,10 +2606,9 @@ void long_to_string (char *, long); void print_internal (Lisp_Object, Lisp_Object, int); void print_symbol (Lisp_Object, Lisp_Object, int); void print_float (Lisp_Object, Lisp_Object, int); -void print_compiled_function (Lisp_Object, Lisp_Object, int); extern int print_escape_newlines; extern int print_readably; -Lisp_Object internal_with_output_to_temp_buffer (CONST char *, +Lisp_Object internal_with_output_to_temp_buffer (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object); void float_to_string (char *, double); @@ -2437,6 +2673,9 @@ int symbol_value_buffer_local_info (Lisp_Object, struct buffer *); Lisp_Object find_symbol_value (Lisp_Object); Lisp_Object find_symbol_value_quickly (Lisp_Object, int); Lisp_Object top_level_value (Lisp_Object); +void reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, + int function_p, + Lisp_Object follow_past_lisp_magic); /* Defined in syntax.c */ int scan_words (struct buffer *, int, int); @@ -2492,7 +2731,6 @@ EXFUN (Fchar_after, 2); EXFUN (Fchar_to_string, 1); EXFUN (Fcheck_valid_plist, 1); EXFUN (Fclear_range_table, 1); -EXFUN (Fclrhash, 1); EXFUN (Fcoding_category_list, 0); EXFUN (Fcoding_category_system, 1); EXFUN (Fcoding_priority_list, 0); @@ -2505,12 +2743,12 @@ EXFUN (Fcoding_system_property, 2); EXFUN (Fcoding_system_type, 1); EXFUN (Fcommand_execute, 3); EXFUN (Fcommandp, 1); -EXFUN (Fcompiled_function_domain, 1); EXFUN (Fconcat, MANY); EXFUN (Fcons, 2); EXFUN (Fcopy_alist, 1); EXFUN (Fcopy_coding_system, 2); EXFUN (Fcopy_event, 2); +EXFUN (Fcopy_list, 1); EXFUN (Fcopy_marker, 2); EXFUN (Fcopy_sequence, 1); EXFUN (Fcopy_tree, 2); @@ -2577,11 +2815,9 @@ EXFUN (Fget_buffer_process, 1); EXFUN (Fget_coding_system, 1); EXFUN (Fget_process, 1); EXFUN (Fget_range_table, 3); -EXFUN (Fgethash, 3); EXFUN (Fgettext, 1); EXFUN (Fgoto_char, 2); EXFUN (Fgtr, MANY); -EXFUN (Fhashtablep, 1); EXFUN (Findent_to, 3); EXFUN (Findirect_function, 1); EXFUN (Finsert, MANY); @@ -2604,7 +2840,6 @@ EXFUN (Flss, MANY); EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_coding_system, 4); EXFUN (Fmake_glyph_internal, 1); -EXFUN (Fmake_hashtable, 2); EXFUN (Fmake_list, 2); EXFUN (Fmake_marker, 0); EXFUN (Fmake_range_table, 0); @@ -2652,7 +2887,6 @@ EXFUN (Fpurecopy, 1); EXFUN (Fput, 3); EXFUN (Fput_range_table, 4); EXFUN (Fput_text_property, 5); -EXFUN (Fputhash, 3); EXFUN (Fquo, MANY); EXFUN (Frassq, 2); EXFUN (Fread, 1); @@ -2720,8 +2954,9 @@ extern Lisp_Object Qbyte_code, Qcall_interactively, Qcategory; extern Lisp_Object Qcategory_designator_p, Qcategory_table_value_p, Qccl, Qcdr; extern Lisp_Object Qchannel, Qchar, Qchar_or_string_p, Qcharacter, Qcharacterp; extern Lisp_Object Qchars, Qcharset_g0, Qcharset_g1, Qcharset_g2, Qcharset_g3; -extern Lisp_Object Qcircular_property_list, Qcoding_system_error; -extern Lisp_Object Qcoding_system_p, Qcolor, Qcolor_pixmap_image_instance_p; +extern Lisp_Object Qcircular_list, Qcircular_property_list; +extern Lisp_Object Qcoding_system_error, Qcoding_system_p; +extern Lisp_Object Qcolor, Qcolor_pixmap_image_instance_p; extern Lisp_Object Qcolumns, Qcommand, Qcommandp, Qcompletion_ignore_case; extern Lisp_Object Qconsole, Qconsole_live_p, Qconst_specifier, Qcr, Qcritical; extern Lisp_Object Qcrlf, Qctext, Qcurrent_menubar, Qcursor; @@ -2746,11 +2981,12 @@ extern Lisp_Object Qinteger_or_marker_p, Qintegerp, Qinteractive, Qinternal; extern Lisp_Object Qinvalid_function, Qinvalid_read_syntax, Qio_error; extern Lisp_Object Qiso2022, Qkey, Qkey_assoc, Qkeymap, Qlambda, Qleft, Qlf; extern Lisp_Object Qlist, Qlistp, Qload, Qlock_shift, Qmacro, Qmagic; -extern Lisp_Object Qmalformed_property_list, Qmalloc_overhead, Qmark, Qmarkers; +extern Lisp_Object Qmalformed_list, Qmalformed_property_list; +extern Lisp_Object Qmalloc_overhead, Qmark, Qmarkers; extern Lisp_Object Qmax, Qmemory, Qmessage, Qminus, Qmnemonic, Qmodifiers; extern Lisp_Object Qmono_pixmap_image_instance_p, Qmotion; extern Lisp_Object Qmouse_leave_buffer_hook, Qmswindows, Qname, Qnas, Qnatnump; -extern Lisp_Object Qnil, Qno_ascii_cntl, Qno_ascii_eol, Qno_catch; +extern Lisp_Object Qno_ascii_cntl, Qno_ascii_eol, Qno_catch; extern Lisp_Object Qno_conversion, Qno_iso6429, Qnone, Qnot, Qnothing; extern Lisp_Object Qnothing_image_instance_p, Qnotice; extern Lisp_Object Qnumber_char_or_marker_p, Qnumber_or_marker_p, Qnumberp; @@ -2785,7 +3021,7 @@ extern Lisp_Object Vascii_upcase_table, Vautoload_queue, Vbinary_process_input; extern Lisp_Object Vbinary_process_output, Vblank_menubar; extern Lisp_Object Vcharset_ascii, Vcharset_composite, Vcharset_control_1; extern Lisp_Object Vcoding_system_for_read, Vcoding_system_for_write; -extern Lisp_Object Vcoding_system_hashtable, Vcommand_history; +extern Lisp_Object Vcoding_system_hash_table, Vcommand_history; extern Lisp_Object Vcommand_line_args, Vconfigure_info_directory; extern Lisp_Object Vconsole_list, Vcontrolling_terminal; extern Lisp_Object Vcurrent_compiled_function_annotation, Vcurrent_load_list; @@ -2815,5 +3051,6 @@ extern Lisp_Object Vthis_command_keys, Vunread_command_event; extern Lisp_Object Vwin32_generate_fake_inodes, Vwin32_pipe_read_delay; extern Lisp_Object Vx_initial_argv_list; +extern Lisp_Object Qmakunbound, Qset; #endif /* _XEMACS_LISP_H_ */ diff --git a/src/lread.c b/src/lread.c index 98516f0..479ea25 100644 --- a/src/lread.c +++ b/src/lread.c @@ -29,11 +29,9 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" #include "bytecode.h" -#include "commands.h" -#include "insdel.h" +#include "elhash.h" #include "lstream.h" #include "opaque.h" -#include #ifdef FILE_CODING #include "file-coding.h" #endif @@ -401,22 +399,18 @@ ebolify_bytecode_constants (Lisp_Object vector) something to `funcall', but who would really do that? As they say in law, we've made a "good-faith effort" to unfuckify ourselves. And doing it this way avoids screwing - up args to `make-hashtable' and such. As it is, we have to + up args to `make-hash-table' and such. As it is, we have to add an extra Ebola check in decode_weak_list_type(). --ben */ - if (EQ (el, Qassoc)) - el = Qold_assoc; - if (EQ (el, Qdelq)) - el = Qold_delq; + if (EQ (el, Qassoc)) el = Qold_assoc; + else if (EQ (el, Qdelq)) el = Qold_delq; #if 0 /* I think this is a bad idea because it will probably mess with keymap code. */ - if (EQ (el, Qdelete)) - el = Qold_delete; + else if (EQ (el, Qdelete)) el = Qold_delete; #endif - if (EQ (el, Qrassq)) - el = Qold_rassq; - if (EQ (el, Qrassoc)) - el = Qold_rassoc; + else if (EQ (el, Qrassq)) el = Qold_rassq; + else if (EQ (el, Qrassoc)) el = Qold_rassoc; + XVECTOR_DATA (vector)[i] = el; } } @@ -470,11 +464,11 @@ load_force_doc_string_unwind (Lisp_Object oldlist) Lisp_Object doc; assert (COMPILED_FUNCTIONP (john)); - if (CONSP (XCOMPILED_FUNCTION (john)->bytecodes)) + if (CONSP (XCOMPILED_FUNCTION (john)->instructions)) { struct gcpro ngcpro1; Lisp_Object juan = (pas_de_lache_ici - (fd, XCOMPILED_FUNCTION (john)->bytecodes)); + (fd, XCOMPILED_FUNCTION (john)->instructions)); Lisp_Object ivan; NGCPRO1 (juan); @@ -482,7 +476,7 @@ load_force_doc_string_unwind (Lisp_Object oldlist) if (!CONSP (ivan)) signal_simple_error ("invalid lazy-loaded byte code", ivan); /* Remember to purecopy; see above. */ - XCOMPILED_FUNCTION (john)->bytecodes = Fpurecopy (XCAR (ivan)); + XCOMPILED_FUNCTION (john)->instructions = Fpurecopy (XCAR (ivan)); /* v18 or v19 bytecode file. Need to Ebolify. */ if (XCOMPILED_FUNCTION (john)->flags.ebolified && VECTORP (XCDR (ivan))) @@ -793,7 +787,7 @@ encoding detection or end-of-line detection. if (purify_flag && noninteractive) { if (EQ (last_file_loaded, file)) - message_append (" (%ld)", + message_append (" (%ld)", (unsigned long) (purespace_usage() - pure_usage)); else message ("Loading %s ...done (%ld)", XSTRING_DATA (file), @@ -848,10 +842,11 @@ for details. if (!NILP (mode)) CHECK_NATNUM (mode); - locate_file (path_list, filename, - ((NILP (suffixes)) ? "" : - (char *) (XSTRING_DATA (suffixes))), - &tp, (NILP (mode) ? R_OK : XINT (mode))); + locate_file (path_list, + filename, + NILP (suffixes) ? "" : (char *) XSTRING_DATA (suffixes), + &tp, + NILP (mode) ? R_OK : XINT (mode)); return tp; } @@ -860,8 +855,7 @@ for details. static Lisp_Object locate_file_refresh_hashing (Lisp_Object str) { - Lisp_Object hash = - make_directory_hash_table ((char *) XSTRING_DATA (str)); + Lisp_Object hash = make_directory_hash_table ((char *) XSTRING_DATA (str)); Fput (str, Qlocate_file_hash_table, hash); return hash; } @@ -872,7 +866,7 @@ static Lisp_Object locate_file_find_directory_hash_table (Lisp_Object str) { Lisp_Object hash = Fget (str, Qlocate_file_hash_table, Qnil); - if (NILP (Fhashtablep (hash))) + if (! HASH_TABLEP (hash)) return locate_file_refresh_hashing (str); return hash; } @@ -904,7 +898,7 @@ locate_file_in_directory (Lisp_Object path, Lisp_Object str, default-directory to be something non-absolute ... */ { if (NILP (filename)) - /* NIL means current dirctory */ + /* NIL means current directory */ filename = current_buffer->directory; else filename = Fexpand_file_name (filename, @@ -1119,7 +1113,7 @@ locate_file (Lisp_Object path, Lisp_Object str, CONST char *suffix, for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail)) { Lisp_Object pathel = Fcar (pathtail); - Lisp_Object hashtab; + Lisp_Object hash_table; Lisp_Object tail; int found; @@ -1138,13 +1132,13 @@ locate_file (Lisp_Object path, Lisp_Object str, CONST char *suffix, continue; } - hashtab = locate_file_find_directory_hash_table (pathel); + hash_table = locate_file_find_directory_hash_table (pathel); /* Loop over suffixes. */ for (tail = suffixtab, found = 0; !found && CONSP (tail); tail = XCDR (tail)) { - if (!NILP (Fgethash (XCAR (tail), hashtab, Qnil))) + if (!NILP (Fgethash (XCAR (tail), hash_table, Qnil))) found = 1; } @@ -1274,9 +1268,9 @@ readevalloop (Lisp_Object readcharfun, { /* This function can GC */ REGISTER Emchar c; - REGISTER Lisp_Object val; + REGISTER Lisp_Object val = Qnil; int speccount = specpdl_depth (); - struct gcpro gcpro1; + struct gcpro gcpro1, gcpro2; struct buffer *b = 0; if (BUFFERP (readcharfun)) @@ -1293,7 +1287,7 @@ readevalloop (Lisp_Object readcharfun, #ifdef COMPILED_FUNCTION_ANNOTATION_HACK Vcurrent_compiled_function_annotation = Qnil; #endif - GCPRO1 (sourcename); + GCPRO2 (val, sourcename); LOADHIST_ATTACH (sourcename); @@ -2401,11 +2395,11 @@ retry: obj = read0(readcharfun); /* the call to `featurep' may GC. */ - GCPRO2(fexp, obj); - tem = call1(Qfeaturep, fexp); + GCPRO2 (fexp, obj); + tem = call1 (Qfeaturep, fexp); UNGCPRO; - if (c == '+' && NILP(tem)) goto retry; + if (c == '+' && NILP(tem)) goto retry; if (c == '-' && !NILP(tem)) goto retry; return obj; } @@ -2991,7 +2985,7 @@ init_lread (void) Vvalues = Qnil; load_in_progress = 0; - + Vload_descriptor_list = Qnil; /* kludge: locate-file does not work for a null load-path, even if diff --git a/src/lrecord.h b/src/lrecord.h index dae210b..b15c1cb 100644 --- a/src/lrecord.h +++ b/src/lrecord.h @@ -50,7 +50,7 @@ Boston, MA 02111-1307, USA. */ a `next' pointer, and are allocated using alloc_lcrecord(). Creating a new lcrecord type is fairly easy; just follow the - lead of some existing type (e.g. hashtables). Note that you + lead of some existing type (e.g. hash tables). Note that you do not need to supply all the methods (see below); reasonable defaults are provided for many of them. Alternatively, if you're just looking for a way of encapsulating data (which possibly @@ -89,11 +89,11 @@ struct lrecord_header */ #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION /* index into lrecord_implementations_table[] */ - unsigned type:8; + unsigned char type; /* 1 if the object is marked during GC, 0 otherwise. */ - unsigned mark:1; + char mark; /* 1 if the object resides in pure (read-only) space */ - unsigned pure:1; + char pure; #else CONST struct lrecord_implementation *implementation; #endif @@ -103,11 +103,11 @@ struct lrecord_implementation; int lrecord_type_index (CONST struct lrecord_implementation *implementation); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION -# define set_lheader_implementation(header,imp) do \ -{ \ - (header)->type = lrecord_type_index (imp); \ - (header)->mark = 0; \ - (header)->pure = 0; \ +# define set_lheader_implementation(header,imp) do { \ + struct lrecord_header* SLI_header = (header); \ + (SLI_header)->type = lrecord_type_index (imp); \ + (SLI_header)->mark = 0; \ + (SLI_header)->pure = 0; \ } while (0) #else # define set_lheader_implementation(header,imp) \ @@ -117,27 +117,31 @@ int lrecord_type_index (CONST struct lrecord_implementation *implementation); struct lcrecord_header { struct lrecord_header lheader; - /* The "next" field is normally used to chain all lrecords together + + /* The `next' field is normally used to chain all lrecords together so that the GC can find (and free) all of them. - "alloc_lcrecord" threads records together. + `alloc_lcrecord' threads records together. + + The `next' field may be used for other purposes as long as some + other mechanism is provided for letting the GC do its work. - The "next" field may be used for other purposes as long as some - other mechanism is provided for letting the GC do its work. (For - example, the event and marker datatypes allocate members out of - memory chunks, and are able to find all unmarked members by - sweeping through the elements of the list of chunks) */ + For example, the event and marker object types allocate members + out of memory chunks, and are able to find all unmarked members + by sweeping through the elements of the list of chunks. */ struct lcrecord_header *next; - /* This is just for debugging/printing convenience. - Having this slot doesn't hurt us much spacewise, since an lcrecord - already has the above slots together with malloc overhead. */ + + /* The `uid' field is just for debugging/printing convenience. + Having this slot doesn't hurt us much spacewise, since an + lcrecord already has the above slots plus malloc overhead. */ unsigned int uid :31; - /* A flag that indicates whether this lcrecord is on a "free list". - Free lists are used to minimize the number of calls to malloc() - when we're repeatedly allocating and freeing a number of the - same sort of lcrecord. Lcrecords on a free list always get - marked in a different fashion, so we can use this flag as a - sanity check to make sure that free lists only have freed lcrecords - and there are no freed lcrecords elsewhere. */ + + /* The `free' field is a flag that indicates whether this lcrecord + is on a "free list". Free lists are used to minimize the number + of calls to malloc() when we're repeatedly allocating and freeing + a number of the same sort of lcrecord. Lcrecords on a free list + always get marked in a different fashion, so we can use this flag + as a sanity check to make sure that free lists only have freed + lcrecords and there are no freed lcrecords elsewhere. */ unsigned int free :1; }; @@ -149,7 +153,7 @@ struct free_lcrecord_header }; /* This as the value of lheader->implementation->finalizer - * means that this record is already marked */ + means that this record is already marked */ void this_marks_a_marked_record (void *, int); /* see alloc.c for an explanation */ @@ -232,24 +236,21 @@ extern int gc_in_progress; #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION -# define MARKED_RECORD_HEADER_P(lheader) (lheader)->mark -# define MARK_RECORD_HEADER(lheader) (lheader)->mark = 1 -# define UNMARK_RECORD_HEADER(lheader) (lheader)->mark = 0 +# define MARKED_RECORD_HEADER_P(lheader) ((lheader)->mark) +# define MARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 1)) +# define UNMARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 0)) #else /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */ # define MARKED_RECORD_HEADER_P(lheader) \ - (((lheader)->implementation->finalizer) == this_marks_a_marked_record) -# define MARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)++); } while (0) -# define UNMARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)--); } while (0) + ((lheader)->implementation->finalizer == this_marks_a_marked_record) +# define MARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)++)) +# define UNMARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)--)) #endif /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */ #define UNMARKABLE_RECORD_HEADER_P(lheader) \ - ((LHEADER_IMPLEMENTATION (lheader)->marker) \ - == this_one_is_unmarkable) + (LHEADER_IMPLEMENTATION (lheader)->marker == this_one_is_unmarkable) /* Declaring the following structures as const puts them in the text (read-only) segment, which makes debugging inconvenient @@ -325,25 +326,25 @@ CONST_IF_NOT_DEBUG struct lrecord_implementation lrecord_##c_name[2] = \ # define DECLARE_LRECORD(c_name, structtype) \ extern CONST_IF_NOT_DEBUG struct lrecord_implementation \ lrecord_##c_name[]; \ -INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ +INLINE structtype *error_check_##c_name (Lisp_Object obj); \ INLINE structtype * \ -error_check_##c_name (Lisp_Object _obj) \ +error_check_##c_name (Lisp_Object obj) \ { \ - XUNMARK (_obj); \ - assert (RECORD_TYPEP (_obj, lrecord_##c_name) || \ - MARKED_RECORD_P (_obj)); \ - return (structtype *) XPNTR (_obj); \ + XUNMARK (obj); \ + assert (RECORD_TYPEP (obj, lrecord_##c_name) || \ + MARKED_RECORD_P (obj)); \ + return (structtype *) XPNTR (obj); \ } \ extern Lisp_Object Q##c_name##p # define DECLARE_NONRECORD(c_name, type_enum, structtype) \ -INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ +INLINE structtype *error_check_##c_name (Lisp_Object obj); \ INLINE structtype * \ -error_check_##c_name (Lisp_Object _obj) \ +error_check_##c_name (Lisp_Object obj) \ { \ - XUNMARK (_obj); \ - assert (XGCTYPE (_obj) == type_enum); \ - return (structtype *) XPNTR (_obj); \ + XUNMARK (obj); \ + assert (XGCTYPE (obj) == type_enum); \ + return (structtype *) XPNTR (obj); \ } \ extern Lisp_Object Q##c_name##p diff --git a/src/lstream.c b/src/lstream.c index 16bbfe5..1624dbb 100644 --- a/src/lstream.c +++ b/src/lstream.c @@ -146,8 +146,8 @@ print_lstream (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) Lstream *lstr = XLSTREAM (obj); char buf[200]; - sprintf (buf, "#", - lstr->imp->name, lstr); + sprintf (buf, "#", + lstr->imp->name, (long) lstr); write_c_string (buf, printcharfun); } @@ -1617,8 +1617,8 @@ lisp_buffer_marker (Lisp_Object stream, void (*markobj) (Lisp_Object)) struct lisp_buffer_stream *str = LISP_BUFFER_STREAM_DATA (XLSTREAM (stream)); - (markobj) (str->start); - (markobj) (str->end); + markobj (str->start); + markobj (str->end); return str->buffer; } diff --git a/src/make-src-depend b/src/make-src-depend index a5ace1a..a66f070 100644 --- a/src/make-src-depend +++ b/src/make-src-depend @@ -35,6 +35,7 @@ The dependencies are written to stdout. die $usage if @ARGV; ($srcdir = $0) =~ s@[^/]+$@@; +$srcdir = "." if $srcdir eq ""; chdir $srcdir or die "$srcdir: $!"; opendir SRCDIR, "." or die "$srcdir: $!"; diff --git a/src/malloc.c b/src/malloc.c index 1582286..c34403c 100644 --- a/src/malloc.c +++ b/src/malloc.c @@ -184,7 +184,7 @@ what you give them. Help stamp out software-hoarding! */ #include #endif /* BSD4_2 */ -#ifdef __STDC_ +#ifdef __STDC__ #ifndef HPUX /* not sure where this for NetBSD should really go and it probably applies to other systems */ diff --git a/src/marker.c b/src/marker.c index 88ef60b..59a81aa 100644 --- a/src/marker.c +++ b/src/marker.c @@ -75,16 +75,15 @@ print_marker (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) } static int -marker_equal (Lisp_Object o1, Lisp_Object o2, int depth) +marker_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct buffer *b1 = XMARKER (o1)->buffer; - if (b1 != XMARKER (o2)->buffer) - return (0); - else if (!b1) - /* All markers pointing nowhere are equal */ - return (1); - else - return ((XMARKER (o1)->memind == XMARKER (o2)->memind)); + struct Lisp_Marker *marker1 = XMARKER (obj1); + struct Lisp_Marker *marker2 = XMARKER (obj2); + + return ((marker1->buffer == marker2->buffer) && + (marker1->memind == marker2->memind || + /* All markers pointing nowhere are equal */ + !marker1->buffer)); } static unsigned long @@ -180,7 +179,7 @@ set_marker_internal (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer, (MARKERP (pos) && !XMARKER (pos)->buffer)) { if (point_p) - signal_simple_error ("can't make point-marker point nowhere", + signal_simple_error ("Can't make point-marker point nowhere", marker); if (XMARKER (marker)->buffer) unchain_marker (marker); @@ -199,7 +198,7 @@ set_marker_internal (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer, { if (point_p) signal_simple_error - ("can't move point-marker in a killed buffer", marker); + ("Can't move point-marker in a killed buffer", marker); if (XMARKER (marker)->buffer) unchain_marker (marker); return marker; @@ -237,7 +236,7 @@ set_marker_internal (Lisp_Object marker, Lisp_Object pos, Lisp_Object buffer, if (m->buffer != b) { if (point_p) - signal_simple_error ("can't change buffer of point-marker", marker); + signal_simple_error ("Can't change buffer of point-marker", marker); if (m->buffer != 0) unchain_marker (marker); m->buffer = b; diff --git a/src/md5.c b/src/md5.c index 2b204ff..86fb828 100644 --- a/src/md5.c +++ b/src/md5.c @@ -27,10 +27,7 @@ #endif #include - -#include #include - #include #if defined HAVE_LIMITS_H || _LIBC diff --git a/src/menubar-msw.c b/src/menubar-msw.c index 2075f92..218b2a8 100644 --- a/src/menubar-msw.c +++ b/src/menubar-msw.c @@ -22,12 +22,12 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ -/* Autorship: +/* Author: Initially written by kkm 12/24/97, peeking into and copying stuff from menubar-x.c */ -/* Algotirhm for handling menus is as follows. When window's menubar +/* Algorithm for handling menus is as follows. When window's menubar * is created, current-menubar is not traversed in depth. Rather, only * top level items, both items and pulldowns, are added to the * menubar. Each pulldown is initially empty. When a pulldown is @@ -39,37 +39,37 @@ Boston, MA 02111-1307, USA. */ * descriptor list given menu handle. The key is an opaque ptr data * type, keeping menu handle, and the value is a list of strings * representing the path from the root of the menu to the item - * descriptor. Each frame has an associated hashtable. + * descriptor. Each frame has an associated hash table. * * Leaf items are assigned a unique id based on item's hash. When an * item is selected, Windows sends back the id. Unfortunately, only * low 16 bit of the ID are sent, and there's no way to get the 32-bit * value. Yes, Win32 is just a different set of bugs than X! Aside - * from this blame, another hasing mechanism is required to map menu + * from this blame, another hashing mechanism is required to map menu * ids to commands (which are actually Lisp_Object's). This mapping is - * performed in the same hashtable, as the lifetime of both maps is - * exactly the same. This is unabmigous, as menu handles are + * performed in the same hash table, as the lifetime of both maps is + * exactly the same. This is unambigous, as menu handles are * represented by lisp opaques, while command ids are by lisp * integers. The additional advantage for this is that command forms * are automatically GC-protected, which is important because these * may be transient forms generated by :filter functions. * - * The hashtable is not allowed to grow too much; it is pruned + * The hash table is not allowed to grow too much; it is pruned * whenever this is safe to do. This is done by re-creating the menu * bar, and clearing and refilling the hash table from scratch. * - * Popup menus are handled identially to pulldowns. A static hash + * Popup menus are handled identically to pulldowns. A static hash * table is used for popup menus, and lookup is made not in * current-menubar but in a lisp form supplied to the `popup' * function. * * Another Windows weirdness is that there's no way to tell that a * popup has been dismissed without making selection. We need to know - * that to cleanup the popup menu hashtable, but this is not honestly + * that to cleanup the popup menu hash table, but this is not honestly * doable using *documented* sequence of messages. Sticking to * particular knowledge is bad because this may break in Windows NT * 5.0, or Windows 98, or other future version. Instead, I allow the - * hashtables to hang around, and not clear them, unless WM_COMMAND is + * hash tables to hang around, and not clear them, unless WM_COMMAND is * received. This is worthy some memory but more safe. Hacks welcome, * anyways! * @@ -101,8 +101,8 @@ Boston, MA 02111-1307, USA. */ /* Current menu (bar or popup) descriptor. gcpro'ed */ static Lisp_Object current_menudesc; -/* Current menubar or popup hashtable. gcpro'ed */ -static Lisp_Object current_hashtable; +/* Current menubar or popup hash table. gcpro'ed */ +static Lisp_Object current_hash_table; /* This is used to allocate unique ids to menu items. Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX. @@ -125,7 +125,7 @@ static HMENU top_level_menu; static char* displayable_menu_item (struct gui_item* pgui_item, int bar_p) { - /* We construct the name in a static buffer. That's fine, beause + /* We construct the name in a static buffer. That's fine, because menu items longer than 128 chars are probably programming errors, and better be caught than displayed! */ @@ -160,7 +160,7 @@ hmenu_to_lisp_object (HMENU hmenu) /* * Allocation tries a hash based on item's path and name first. This * almost guarantees that the same item will override its old value in - * the hashtable rather than abandon it. + * the hash table rather than abandon it. */ static Lisp_Object allocate_menu_item_id (Lisp_Object path, Lisp_Object name, Lisp_Object suffix) @@ -190,9 +190,9 @@ empty_menu (HMENU menu, int add_empty_p) /* * The idea of checksumming is that we must hash minimal object - * which is neccessarily changes when the item changes. For separator + * which is necessarily changes when the item changes. For separator * this is a constant, for grey strings and submenus these are hashes - * of names, since sumbenus are unpopulated until opened so always + * of names, since submenus are unpopulated until opened so always * equal otherwise. For items, this is a full hash value of a callback, * because a callback may me a form which can be changed only somewhere * in depth. @@ -355,7 +355,7 @@ populate_menu_add_item (HMENU menu, Lisp_Object path, * This function is called from populate_menu and checksum_menu. * When called to populate, MENU is a menu handle, PATH is a * list of strings representing menu path from root to this submenu, - * DESCRIPTOR is a menu descriptor, HASH_TAB is a hashtable associated + * DESCRIPTOR is a menu descriptor, HASH_TAB is a hash table associated * with root menu, BAR_P indicates whether this called for a menubar or * a popup, and POPULATE_P is non-zero. Return value must be ignored. * When called to checksum, DESCRIPTOR has the same meaning, POPULATE_P @@ -376,7 +376,7 @@ populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object desc, GCPRO_GUI_ITEM (&gui_item); /* We are sometimes called with the menubar unchanged, and with changed - right flush. We have to update the menubar in ths case, + right flush. We have to update the menubar in this case, so account for the compliance setting in the hash value */ checksum = REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIHGT_FLUSH; @@ -404,7 +404,7 @@ populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object desc, { if (NILP (XCAR (item_desc))) { - /* Do not flush right menubar items when MS style compiant */ + /* Do not flush right menubar items when MS style compliant */ if (bar_p && !REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIHGT_FLUSH) flush_right = 1; if (!populate_p) @@ -426,7 +426,7 @@ populate_or_checksum_helper (HMENU menu, Lisp_Object path, Lisp_Object desc, /* Add the header to the popup, if told so. The same as in X - an insensitive item, and a separator (Seems to me, there were - two separators in X... In Windows this looks ugly, anywats. */ + two separators in X... In Windows this looks ugly, anyways. */ if (!bar_p && !deep_p && popup_menu_titles && !NILP(gui_item.name)) { CHECK_STRING (gui_item.name); @@ -467,7 +467,7 @@ update_frame_menubar_maybe (struct frame* f) if (NILP (desc) && menubar != NULL) { /* Menubar has gone */ - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil; SetMenu (FRAME_MSWINDOWS_HANDLE (f), NULL); DestroyMenu (menubar); DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f)); @@ -493,15 +493,16 @@ update_frame_menubar_maybe (struct frame* f) populate: /* Come with empty hash table */ - if (NILP (FRAME_MSWINDOWS_MENU_HASHTABLE(f))) - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Fmake_hashtable (make_int (50), Qequal); + if (NILP (FRAME_MSWINDOWS_MENU_HASH_TABLE(f))) + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); else - Fclrhash (FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); Fputhash (hmenu_to_lisp_object (menubar), Qnil, - FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); populate_menu (menubar, Qnil, desc, - FRAME_MSWINDOWS_MENU_HASHTABLE(f), 1); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f), 1); SetMenu (FRAME_MSWINDOWS_HANDLE (f), menubar); DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f)); @@ -517,7 +518,7 @@ prune_menubar (struct frame *f) return; /* #### If a filter function has set desc to Qnil, this abort() - triggers. To resolve, we must prevent filters explicitely from + triggers. To resolve, we must prevent filters explicitly from mangling with the active menu. In apply_filter probably? Is copy-tree on the whole menu too expensive? */ if (NILP(desc)) @@ -527,25 +528,25 @@ prune_menubar (struct frame *f) /* We do the trick by removing all items and re-populating top level */ empty_menu (menubar, 0); - assert (HASHTABLEP (FRAME_MSWINDOWS_MENU_HASHTABLE(f))); - Fclrhash (FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + assert (HASH_TABLEP (FRAME_MSWINDOWS_MENU_HASH_TABLE(f))); + Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); Fputhash (hmenu_to_lisp_object (menubar), Qnil, - FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); populate_menu (menubar, Qnil, desc, - FRAME_MSWINDOWS_MENU_HASHTABLE(f), 1); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f), 1); } /* * This is called when cleanup is possible. It is better not to - * clean things up at all than do it too earaly! + * clean things up at all than do it too early! */ static void menu_cleanup (struct frame *f) { /* This function can GC */ current_menudesc = Qnil; - current_hashtable = Qnil; + current_hash_table = Qnil; prune_menubar (f); } @@ -563,7 +564,7 @@ unsafe_handle_wm_initmenupopup_1 (HMENU menu, struct frame* f) struct gcpro gcpro1; /* Find which guy is going to explode */ - path = Fgethash (hmenu_to_lisp_object (menu), current_hashtable, Qunbound); + path = Fgethash (hmenu_to_lisp_object (menu), current_hash_table, Qunbound); assert (!UNBOUNDP (path)); #ifdef DEBUG_XEMACS /* Allow to continue in a debugger after assert - not so fatal */ @@ -580,7 +581,7 @@ unsafe_handle_wm_initmenupopup_1 (HMENU menu, struct frame* f) /* Now, stuff it */ /* DESC may be generated by filter, so we have to gcpro it */ GCPRO1 (desc); - populate_menu (menu, path, desc, current_hashtable, 0); + populate_menu (menu, path, desc, current_hash_table, 0); UNGCPRO; return Qt; } @@ -603,8 +604,8 @@ unsafe_handle_wm_initmenu_1 (struct frame* f) update_frame_menubar_maybe (f); current_menudesc = current_frame_menubar (f); - current_hashtable = FRAME_MSWINDOWS_MENU_HASHTABLE(f); - assert (HASHTABLEP (current_hashtable)); + current_hash_table = FRAME_MSWINDOWS_MENU_HASH_TABLE(f); + assert (HASH_TABLEP (current_hash_table)); return Qt; } @@ -622,14 +623,14 @@ mswindows_handle_wm_command (struct frame* f, WORD id) Lisp_Object data, fn, arg, frame; struct gcpro gcpro1; - data = Fgethash (make_int (id), current_hashtable, Qunbound); + data = Fgethash (make_int (id), current_hash_table, Qunbound); if (UNBOUNDP (data)) { menu_cleanup (f); return Qnil; } - /* Need to gcpro because the hashtable may get destroyed by + /* Need to gcpro because the hash table may get destroyed by menu_cleanup(), and will not gcpro the data any more */ GCPRO1 (data); menu_cleanup (f); @@ -703,7 +704,7 @@ mswindows_update_frame_menubars (struct frame* f) static void mswindows_free_frame_menubars (struct frame* f) { - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil; } static void @@ -749,9 +750,10 @@ mswindows_popup_menu (Lisp_Object menu_desc, Lisp_Object event) CHECK_STRING (XCAR (menu_desc)); current_menudesc = menu_desc; - current_hashtable = Fmake_hashtable (make_int(10), Qequal); + current_hash_table = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); menu = create_empty_popup_menu(); - Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hashtable); + Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hash_table); top_level_menu = menu; /* see comments in menubar-x.c */ @@ -797,8 +799,8 @@ void vars_of_menubar_mswindows (void) { current_menudesc = Qnil; - current_hashtable = Qnil; + current_hash_table = Qnil; staticpro (¤t_menudesc); - staticpro (¤t_hashtable); + staticpro (¤t_hash_table); } diff --git a/src/menubar-msw.h b/src/menubar-msw.h index 918c276..dee8384 100644 --- a/src/menubar-msw.h +++ b/src/menubar-msw.h @@ -22,7 +22,7 @@ Boston, MA 02111-1307, USA. */ /* Synched up with: Not in FSF. */ -/* Autorship: +/* Author: Initially written by kkm 12/24/97, */ diff --git a/src/menubar-x.c b/src/menubar-x.c index 4964779..f9c5349 100644 --- a/src/menubar-x.c +++ b/src/menubar-x.c @@ -27,9 +27,7 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "console-x.h" -#include "EmacsManager.h" #include "EmacsFrame.h" -#include "EmacsShell.h" #include "gui-x.h" #include "buffer.h" @@ -164,7 +162,7 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, Lisp_Object cascade = desc; desc = Fcdr (desc); if (NILP (desc)) - signal_simple_error ("keyword in menu lacks a value", + signal_simple_error ("Keyword in menu lacks a value", cascade); val = Fcar (desc); desc = Fcdr (desc); @@ -189,7 +187,7 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, /* implement in 21.2 */ } else - signal_simple_error ("unknown menu cascade keyword", cascade); + signal_simple_error ("Unknown menu cascade keyword", cascade); } if ((!NILP (config_tag) @@ -202,7 +200,7 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, if (active_spec) active_p = Feval (active_p); - + if (!NILP (hook_fn) && !NILP (active_p)) { #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF @@ -255,14 +253,14 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, /* Add a fake entry so the menus show up */ wv->contents = dummy = xmalloc_widget_value (); dummy->name = "(inactive)"; - dummy->accel = NULL; + dummy->accel = LISP_TO_VOID (Qnil); dummy->enabled = 0; dummy->selected = 0; dummy->value = NULL; dummy->type = BUTTON_TYPE; dummy->call_data = NULL; dummy->next = NULL; - + goto menu_item_done; } @@ -275,10 +273,10 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, } else { - signal_simple_error ("menu name (first element) must be a string", + signal_simple_error ("Menu name (first element) must be a string", desc); } - + if (deep_p || menubar_root_p) { widget_value *next; @@ -289,7 +287,7 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, { if (partition_seen) error ( - "more than one partition (nil) in menubar description"); + "More than one partition (nil) in menubar description"); partition_seen = 1; next = xmalloc_widget_value (); next->type = PUSHRIGHT_TYPE; @@ -314,7 +312,7 @@ menu_item_descriptor_to_widget_value_1 (Lisp_Object desc, else if (NILP (desc)) error ("nil may not appear in menu descriptions"); else - signal_simple_error ("unrecognized menu descriptor", desc); + signal_simple_error ("Unrecognized menu descriptor", desc); menu_item_done: @@ -615,7 +613,7 @@ set_frame_menubar (struct frame *f, int deep_p, int first_time_p) } -/* Called from x_create_widgets() to create the inital menubar of a frame +/* Called from x_create_widgets() to create the initial menubar of a frame before it is mapped, so that the window is mapped with the menubar already there instead of us tacking it on later and thrashing the window after it is visible. */ @@ -684,7 +682,7 @@ make_dummy_xbutton_event (XEvent *dummy, XtSetArg (al [1], XtNy, &framey); XtGetValues (daddy, al, 2); btn->x_root = shellx + framex + btn->x; - btn->y_root = shelly + framey + btn->y;; + btn->y_root = shelly + framey + btn->y; btn->state = ButtonPressMask; /* all buttons pressed */ } else diff --git a/src/menubar.c b/src/menubar.c index 4e2aa8a..819dd0f 100644 --- a/src/menubar.c +++ b/src/menubar.c @@ -109,7 +109,7 @@ menu_parse_submenu_keywords (Lisp_Object desc, struct gui_item* pgui_item) /* First element may be menu name, although can be omitted. Let's think that if stuff begins with anything than a keyword - or a list (submenu), this is a menu name, expected to be a stirng */ + or a list (submenu), this is a menu name, expected to be a string */ if (!KEYWORDP (XCAR (desc)) && !CONSP (XCAR (desc))) { CHECK_STRING (XCAR (desc)); @@ -156,7 +156,7 @@ See also 'find-menu-item'. gui_item_init (&gui_item); GCPRO_GUI_ITEM (&gui_item); - + EXTERNAL_LIST_LOOP (path_entry, path) { /* Verify that DESC describes a menu, not single item */ @@ -507,7 +507,7 @@ The possible keywords are this: :label
(unimplemented!) Like :suffix, but replaces label completely. (might be added in 21.2). - + For example: ("File" diff --git a/src/minibuf.c b/src/minibuf.c index 6e6c5bc..c87858d 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -289,14 +289,14 @@ ignore_completion_p (Lisp_Object completion_string, } -/* #### Maybe we should allow ALIST to be a hashtable. It is wrong +/* #### Maybe we should allow ALIST to be a hash table. It is wrong for the use of obarrays to be better-rewarded than the use of - hashtables. By better-rewarded I mean that you can pass an obarray + hash tables. By better-rewarded I mean that you can pass an obarray to all of the completion functions, whereas you can't do anything - like that with a hashtable. + like that with a hash table. To do so, there should probably be a - map_obarray_or_alist_or_hashtable function which would be used by + map_obarray_or_alist_or_hash_table function which would be used by both Ftry_completion and Fall_completions. But would the additional funcalls slow things down? */ diff --git a/src/mule-canna.c b/src/mule-canna.c index 8b970e3..931e93c 100644 --- a/src/mule-canna.c +++ b/src/mule-canna.c @@ -372,8 +372,8 @@ If nil is specified for each arg, the default value will be used. char servername[256]; CHECK_STRING (server); - strncpy (servername, XSTRING (server)->_data, XSTRING (server)->_size); - servername[XSTRING (server)->_size] = '\0'; + strncpy (servername, XSTRING_DATA (server), XSTRING_LENGTH (server)); + servername[XSTRING_LENGTH (server)] = '\0'; jrKanjiControl (0, KC_SETSERVERNAME, servername); } @@ -386,8 +386,8 @@ If nil is specified for each arg, the default value will be used. char rcname[256]; CHECK_STRING (rcfile); - strncpy (rcname, XSTRING (rcfile)->_data, XSTRING (rcfile)->_size); - rcname[XSTRING (rcfile)->_size] = '\0'; + strncpy (rcname, XSTRING_DATA (rcfile), XSTRING_LENGTH (rcfile)); + rcname[XSTRING_LENGTH (rcfile)] = '\0'; jrKanjiControl (0, KC_SETINITFILENAME, rcname); } @@ -414,7 +414,7 @@ If nil is specified for each arg, the default value will be used. if (res == -1) { - val = Fcons (make_string ((unsigned char*) jrKanjiError, + val = Fcons (make_string ((unsigned char*) jrKanjiError, strlen (jrKanjiError)), val); /* ¥¤¥Ë¥·¥ã¥é¥¤¥º¤Ç¼ºÇÔ¤·¤¿¾ì¹ç¡£ */ return Fcons (Qnil, val); @@ -490,10 +490,10 @@ Register Kanji words into kana-to-kanji conversion dictionary. ksv.buffer = (unsigned char *) buf; ksv.bytes_buffer = KEYTOSTRSIZE; #ifndef CANNA_MULE - ks.echoStr = XSTRING (str)->_data; - ks.length = XSTRING (str)->_size; + ks.echoStr = XSTRING_DATA (str); + ks.length = XSTRING_LENGTH (str); #else /* CANNA_MULE */ - m2c (XSTRING (str)->_data, XSTRING (str)->_size, cbuf); + m2c (XSTRING_DATA (str), XSTRING_LENGTH (str), cbuf); ks.echoStr = cbuf; ks.length = strlen (cbuf); #endif /* CANNA_MULE */ @@ -504,7 +504,7 @@ Register Kanji words into kana-to-kanji conversion dictionary. } DEFUN ("canna-set-width", Fcanna_set_width, 1, 1, 0, /* -Set status-line width information, which is used to display +Set status-line width information, which is used to display kanji candidates. */ (num)) @@ -564,11 +564,11 @@ Store yomi characters as a YOMI of kana-to-kanji conversion. CHECK_STRING (yomi); #ifndef CANNA_MULE - strncpy (buf, XSTRING (yomi)->_data, XSTRING (yomi)->_size); - ks.length = XSTRING (yomi)->_size; + strncpy (buf, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi)); + ks.length = XSTRING_LENGTH (yomi); buf[ks.length] = '\0'; #else /* CANNA_MULE */ - m2c (XSTRING (yomi)->_data, XSTRING (yomi)->_size, buf); + m2c (XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), buf); ks.length = strlen (buf); #endif /* CANNA_MULE */ @@ -581,13 +581,13 @@ Store yomi characters as a YOMI of kana-to-kanji conversion. CHECK_STRING (roma); #ifndef CANNA_MULE - strncpy (buf + XSTRING (yomi)->_size + 1, XSTRING (roma)->_data, - XSTRING (roma)->_size); - buf[XSTRING (yomi)->_size + 1 + XSTRING (roma)->_size] = '\0'; - ks.mode = (unsigned char *)(buf + XSTRING (yomi)->_size + 1); + strncpy (buf + XSTRING_LENGTH (yomi) + 1, XSTRING_DATA (roma), + XSTRING_LENGTH (roma)); + buf[XSTRING_LENGTH (yomi) + 1 + XSTRING_LENGTH (roma)] = '\0'; + ks.mode = (unsigned char *)(buf + XSTRING_LENGTH (yomi) + 1); #else /* CANNA_MULE */ ks.mode = (unsigned char *)(buf + ks.length + 1); - m2c (XSTRING (roma)->_data, XSTRING (roma)->_size, ks.mode); + m2c (XSTRING_DATA (roma), XSTRING_LENGTH (roma), ks.mode); #endif /* CANNA_MULE */ } @@ -643,10 +643,10 @@ Parse customize string. CHECK_STRING (str); #ifndef CANNA_MULE - strncpy (buf, XSTRING (str)->_data, XSTRING (str)->_size); - buf[XSTRING (str)->_size] = '\0'; + strncpy (buf, XSTRING_DATA (str), XSTRING_LENGTH (str)); + buf[XSTRING_LENGTH (str)] = '\0'; #else /* CANNA_MULE */ - m2c (XSTRING (str)->_data, XSTRING (str)->_size, buf); + m2c (XSTRING_DATA (str), XSTRING_LENGTH (str), buf); #endif /* CANNA_MULE */ p = (unsigned char**) buf; n = jrKanjiControl (0, KC_PARSE, (char *) &p); @@ -730,12 +730,12 @@ DEFUN ("canna-henkan-begin", Fcanna_henkan_begin, 1, 1, 0, /* return Qnil; } #ifndef CANNA_MULE - strncpy (yomibuf, XSTRING (yomi)->_data, XSTRING (yomi)->_size); - yomibuf[XSTRING (yomi)->_size] = '\0'; - nbun = RkBgnBun (IRCP_context, XSTRING (yomi)->_data, XSTRING (yomi)->_size, + strncpy (yomibuf, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi)); + yomibuf[XSTRING_LENGTH (yomi)] = '\0'; + nbun = RkBgnBun (IRCP_context, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), (RK_XFER << RK_XFERBITS) | RK_KFER); #else /* CANNA_MULE */ - m2c (XSTRING (yomi)->_data, XSTRING (yomi)->_size, yomibuf); + m2c (XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), yomibuf); nbun = RkBgnBun (IRCP_context, (char *) yomibuf, strlen (yomibuf), (RK_XFER << RK_XFERBITS) | RK_KFER); #endif /* CANNA_MULE */ @@ -814,7 +814,7 @@ DEFUN ("canna-bunsetu-henkou", Fcanna_bunsetu_henkou, 2, 2, 0, /* CHECK_INT (bunsetsu); CHECK_INT (bunlen); - + nbun = XINT (bunsetsu); if (confirmContext () == 0) { @@ -1024,7 +1024,7 @@ syms_of_mule_canna (void) { DEFVAR_LISP ("CANNA", &VCANNA); /* hir@nec, 1992.5.21 */ VCANNA = Qt; /* hir@nec, 1992.5.21 */ - + DEFSUBR (Fcanna_key_proc); DEFSUBR (Fcanna_initialize); DEFSUBR (Fcanna_finalize); @@ -1780,7 +1780,7 @@ static void c2mu (char *cp, int l, char *mp) { char ch, *ep = cp+l; - + while ((cp < ep) && (ch = *cp)) { if ((unsigned char) ch == ISO_CODE_SS2) @@ -1809,8 +1809,8 @@ c2mu (char *cp, int l, char *mp) static void m2c (unsigned char *mp, int l, unsigned char *cp) { - unsigned char ch, *ep = mp + l;; - + unsigned char ch, *ep = mp + l; + while ((mp < ep) && (ch = *mp++)) { switch (ch) @@ -1829,7 +1829,7 @@ m2c (unsigned char *mp, int l, unsigned char *cp) *cp++ = ch; break; } - } + } *cp = 0; } @@ -1840,10 +1840,10 @@ static Lisp_Object mule_make_string (unsigned char *p, int l) { unsigned char cbuf[4096]; - + c2mu (p,l,cbuf); return (make_string (cbuf,strlen (cbuf))); -} +} /* return the MULE internal string length of EUC string */ /* Modified by sb to return a character count not byte count. */ @@ -1852,7 +1852,7 @@ mule_strlen (unsigned char *p, int l) { unsigned char ch, *cp = p; int len = 0; - + while ((cp < p + l) && (ch = *cp)) { if ((unsigned char) ch == ISO_CODE_SS2) @@ -1873,7 +1873,7 @@ mule_strlen (unsigned char *p, int l) else { len++; - cp++; + cp++; } } return (len); @@ -1885,7 +1885,7 @@ count_char (unsigned char *p, int len, int pos, int rev, int *clen, int *cpos, int *crev) { unsigned char *q = p; - + *clen = *cpos = *crev = 0; if (len == 0) return; while (q < p + pos) @@ -1899,7 +1899,7 @@ count_char (unsigned char *p, int len, int pos, int rev, int *clen, int *cpos, (*clen)++; (*crev)++; if (*q++ & 0x80) q++; - } + } while (q < p + len) { (*clen)++; diff --git a/src/mule-ccl.c b/src/mule-ccl.c index 6bf60e9..dded758 100644 --- a/src/mule-ccl.c +++ b/src/mule-ccl.c @@ -844,7 +844,7 @@ ccl_driver (struct ccl_program *ccl, CONST unsigned char *source, unsigned_char_ case CCL_MOD: reg[rrr] = i % j; break; case CCL_AND: reg[rrr] = i & j; break; case CCL_OR: reg[rrr] = i | j; break; - case CCL_XOR: reg[rrr] = i ^ j;; break; + case CCL_XOR: reg[rrr] = i ^ j; break; case CCL_LSH: reg[rrr] = i << j; break; case CCL_RSH: reg[rrr] = i >> j; break; case CCL_LSH8: reg[rrr] = (i << 8) | j; break; diff --git a/src/mule-charset.c b/src/mule-charset.c index d9b39b8..6e4c96d 100644 --- a/src/mule-charset.c +++ b/src/mule-charset.c @@ -60,11 +60,11 @@ Lisp_Object Vcharset_chinese_cns11643_2; Lisp_Object Vcharset_korean_ksc5601; Lisp_Object Vcharset_composite; -/* Hashtables for composite chars. One maps string representing +/* Hash tables for composite chars. One maps string representing composed chars to their equivalent chars; one goes the other way. */ -Lisp_Object Vcomposite_char_char2string_hashtable; -Lisp_Object Vcomposite_char_string2char_hashtable; +Lisp_Object Vcomposite_char_char2string_hash_table; +Lisp_Object Vcomposite_char_string2char_hash_table; /* Table of charsets indexed by leading byte. */ Lisp_Object charset_by_leading_byte[128]; @@ -136,7 +136,7 @@ Lisp_Object Qascii, Qcontrol_1, Lisp_Object Ql2r, Qr2l; -Lisp_Object Vcharset_hashtable; +Lisp_Object Vcharset_hash_table; static Bufbyte next_allocated_1_byte_leading_byte; static Bufbyte next_allocated_2_byte_leading_byte; @@ -280,7 +280,7 @@ non_ascii_valid_char_p (Emchar ch) if (f1 + FIELD1_TO_OFFICIAL_LEADING_BYTE == LEADING_BYTE_COMPOSITE) { if (UNBOUNDP (Fgethash (make_int (ch), - Vcomposite_char_char2string_hashtable, + Vcomposite_char_char2string_hash_table, Qunbound))) return 0; return 1; @@ -391,9 +391,9 @@ mark_charset (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Charset *cs = XCHARSET (obj); - (markobj) (cs->doc_string); - (markobj) (cs->registry); - (markobj) (cs->ccl_program); + markobj (cs->doc_string); + markobj (cs->registry); + markobj (cs->ccl_program); return cs->name; } @@ -461,7 +461,7 @@ make_charset (int id, Lisp_Object name, Bufbyte leading_byte, unsigned char rep_ CHARSET_TYPE (cs) == CHARSET_TYPE_96) ? 1 : 2; CHARSET_CHARS (cs) = (CHARSET_TYPE (cs) == CHARSET_TYPE_94 || CHARSET_TYPE (cs) == CHARSET_TYPE_94X94) ? 94 : 96; - + if (final) { /* some charsets do not have final characters. This includes @@ -480,7 +480,7 @@ make_charset (int id, Lisp_Object name, Bufbyte leading_byte, unsigned char rep_ /* Some charsets are "faux" and don't have names or really exist at all except in the leading-byte table. */ if (!NILP (name)) - Fputhash (name, obj, Vcharset_hashtable); + Fputhash (name, obj, Vcharset_hash_table); return obj; } @@ -537,7 +537,7 @@ nil is returned. Otherwise the associated charset object is returned. return charset_or_name; CHECK_SYMBOL (charset_or_name); - return Fgethash (charset_or_name, Vcharset_hashtable, Qnil); + return Fgethash (charset_or_name, Vcharset_hash_table, Qnil); } DEFUN ("get-charset", Fget_charset, 1, 1, 0, /* @@ -563,19 +563,15 @@ struct charset_list_closure }; static int -add_charset_to_list_mapper (CONST void *hash_key, void *hash_contents, +add_charset_to_list_mapper (Lisp_Object key, Lisp_Object value, void *charset_list_closure) { /* This function can GC */ - Lisp_Object key, contents; - Lisp_Object *charset_list; struct charset_list_closure *chcl = (struct charset_list_closure*) charset_list_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - charset_list = chcl->charset_list; + Lisp_Object *charset_list = chcl->charset_list; - *charset_list = Fcons (XCHARSET_NAME (contents), *charset_list); + *charset_list = Fcons (XCHARSET_NAME (value), *charset_list); return 0; } @@ -590,7 +586,7 @@ Return a list of the names of all defined charsets. GCPRO1 (charset_list); charset_list_closure.charset_list = &charset_list; - elisp_maphash (add_charset_to_list_mapper, Vcharset_hashtable, + elisp_maphash (add_charset_to_list_mapper, Vcharset_hash_table, &charset_list_closure); UNGCPRO; @@ -966,13 +962,13 @@ static void invalidate_charset_font_caches (Lisp_Object charset) { /* Invalidate font cache entries for charset on all devices. */ - Lisp_Object devcons, concons, hashtab; + Lisp_Object devcons, concons, hash_table; DEVICE_LOOP_NO_BREAK (devcons, concons) { struct device *d = XDEVICE (XCAR (devcons)); - hashtab = Fgethash (charset, d->charset_font_cache, Qunbound); - if (!UNBOUNDP (hashtab)) - Fclrhash (hashtab); + hash_table = Fgethash (charset, d->charset_font_cache, Qunbound); + if (!UNBOUNDP (hash_table)) + Fclrhash (hash_table); } } @@ -1077,7 +1073,7 @@ lookup_composite_char (Bufbyte *str, int len) { Lisp_Object lispstr = make_string (str, len); Lisp_Object ch = Fgethash (lispstr, - Vcomposite_char_string2char_hashtable, + Vcomposite_char_string2char_hash_table, Qunbound); Emchar emch; @@ -1088,9 +1084,9 @@ lookup_composite_char (Bufbyte *str, int len) emch = MAKE_CHAR (Vcharset_composite, composite_char_row_next, composite_char_col_next); Fputhash (make_char (emch), lispstr, - Vcomposite_char_char2string_hashtable); + Vcomposite_char_char2string_hash_table); Fputhash (lispstr, make_char (emch), - Vcomposite_char_string2char_hashtable); + Vcomposite_char_string2char_hash_table); composite_char_col_next++; if (composite_char_col_next >= 128) { @@ -1107,7 +1103,7 @@ Lisp_Object composite_char_string (Emchar ch) { Lisp_Object str = Fgethash (make_char (ch), - Vcomposite_char_char2string_hashtable, + Vcomposite_char_char2string_hash_table, Qunbound); assert (!UNBOUNDP (str)); return str; @@ -1234,9 +1230,9 @@ vars_of_mule_charset (void) void complex_vars_of_mule_charset (void) { - staticpro (&Vcharset_hashtable); - Vcharset_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + staticpro (&Vcharset_hash_table); + Vcharset_hash_table = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); /* Predefined character sets. We store them into variables for ease of access. */ @@ -1410,11 +1406,11 @@ complex_vars_of_mule_charset (void) composite_char_row_next = 32; composite_char_col_next = 32; - Vcomposite_char_string2char_hashtable = - make_lisp_hashtable (500, HASHTABLE_NONWEAK, HASHTABLE_EQUAL); - Vcomposite_char_char2string_hashtable = - make_lisp_hashtable (500, HASHTABLE_NONWEAK, HASHTABLE_EQ); - staticpro (&Vcomposite_char_string2char_hashtable); - staticpro (&Vcomposite_char_char2string_hashtable); + Vcomposite_char_string2char_hash_table = + make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + Vcomposite_char_char2string_hash_table = + make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + staticpro (&Vcomposite_char_string2char_hash_table); + staticpro (&Vcomposite_char_char2string_hash_table); } diff --git a/src/mule-wnnfns.c b/src/mule-wnnfns.c index a4c3629..1569365 100644 --- a/src/mule-wnnfns.c +++ b/src/mule-wnnfns.c @@ -285,7 +285,7 @@ Boston, MA 02111-1307, USA. */ #define WNNSERVER_T 2 #define WNNSERVER_K 3 -int check_wnn_server_type (void); +int check_wnn_server_type (void); void w2m (w_char *wp, unsigned char *mp, unsigned char lb); void m2w (unsigned char *mp, w_char *wp); void w2y (w_char *w); @@ -348,7 +348,7 @@ Return nil if error occurs case WNNSERVER_C: langname = "zh_CN"; break; -/* +/* case WNNSERVER_T: strcpy (langname, "zh_TW"); break; @@ -408,7 +408,7 @@ Return nil if error occurs DEFUN ("wnn-server-close", Fwnn_close, 0, 0, 0, /* -Close the connection to jserver, Dictionary and friquency files +Close the connection to jserver, Dictionary and frequency files are not saved. */ ()) @@ -418,13 +418,13 @@ are not saved. if (!wnnfns_buf[snum]) return Qnil; if (wnnfns_env_norm[snum]) { - if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_norm[snum]); + if (NILP (Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_norm[snum]); else jl_env_sticky_e (wnnfns_env_norm[snum]); jl_disconnect (wnnfns_env_norm[snum]); } if (wnnfns_env_rev[snum]) { - if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_rev[snum]); + if (NILP (Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_rev[snum]); else jl_env_sticky_e (wnnfns_env_rev[snum]); jl_disconnect (wnnfns_env_rev[snum]); } @@ -447,21 +447,21 @@ Specify password files of dictionary and frequency, PW1 and PW2, if needed. CHECK_STRING (args[0]); CHECK_STRING (args[1]); CHECK_INT (args[2]); - if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]); - if (!EQ(args[6], Qnil)) CHECK_STRING (args[6]); + if (! NILP (args[5])) CHECK_STRING (args[5]); + if (! NILP (args[6])) CHECK_STRING (args[6]); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if (jl_dic_add (wnnfns_buf[snum], - XSTRING (args[0])->_data, - XSTRING (args[1])->_data, + XSTRING_DATA (args[0]), + XSTRING_DATA (args[1]), wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT (args[2]), - (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[4], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[5], Qnil)) ? 0 : XSTRING (args[5])->_data, - (EQ(args[6], Qnil)) ? 0 : XSTRING (args[6])->_data, + NILP (args[3]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[4]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[5]) ? 0 : XSTRING_DATA (args[5]), + NILP (args[6]) ? 0 : XSTRING_DATA (args[6]), yes_or_no, puts2 ) < 0) { @@ -496,7 +496,7 @@ Return information of dictionaries. int cnt, i; unsigned char comment[1024]; Lisp_Object val; - int snum; + int snum; unsigned char lb; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -529,7 +529,7 @@ Return information of dictionaries. DEFUN ("wnn-server-dict-comment", Fwnn_dict_comment, 2, 2, 0, /* Set comment to dictionary specified by DIC-NUMBER. Comment string COMMENT -*/ +*/ (dicno, comment)) { w_char wbuf[512]; @@ -538,8 +538,8 @@ Comment string COMMENT CHECK_STRING (comment); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (comment)->_data, wbuf); - if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0) + m2w (XSTRING_DATA (comment), wbuf); + if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0) return Qnil; return Qt; } @@ -552,7 +552,7 @@ Switch the translation mode to normal if T, or reverse if NIL. { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; - if (EQ(rev, Qnil)) + if (NILP (rev)) { if ((!wnnfns_buf[snum]) || (!wnnfns_env_norm[snum])) return Qnil; jl_env_set (wnnfns_buf[snum], wnnfns_env_norm[snum]); @@ -578,15 +578,15 @@ Translate YOMI string to kanji. Retuen the number of bunsetsu. CHECK_STRING (hstring); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (hstring)->_data, wbuf); + m2w (XSTRING_DATA (hstring), wbuf); if (snum == WNNSERVER_C) w2y (wbuf); #ifdef WNN6 - if ((cnt = jl_fi_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) + if ((cnt = jl_fi_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) return Qnil; #else - if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) + if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) return Qnil; #endif return make_int (cnt); @@ -696,7 +696,7 @@ Set candidate with OFFSET, DAI. DAI is T if dai-bunsetsu. CHECK_INT (offset); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - if (EQ(dai, Qnil)) + if (NILP (dai)) { if (jl_set_jikouho (wnnfns_buf[snum], XINT (offset)) < 0) return Qnil; } @@ -722,11 +722,11 @@ Change length of BUN-NUMBER bunsetu to LEN. DAI is T if dai-bunsetsu. no = XINT (bunNo); #ifdef WNN6 if ((cnt = jl_fi_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE, - (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0) + NILP (dai) ? WNN_SHO : WNN_DAI)) < 0) return Qnil; #else if ((cnt = jl_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE, - (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0) + NILP (dai) ? WNN_SHO : WNN_DAI)) < 0) return Qnil; #endif return make_int (cnt); @@ -844,7 +844,7 @@ Update frequency of bunsetsu specified by NUM-NUMBER. int no; int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; - if (EQ(bunNo, Qnil)) no = -1; + if (NILP (bunNo)) no = -1; else { CHECK_INT (bunNo); @@ -875,13 +875,13 @@ DIC-NUMBER, KANJI, YOMI, COMMENT, HINSI-NUMBER CHECK_INT (hinsi); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (yomi)->_data, yomi_buf); + m2w (XSTRING_DATA (yomi), yomi_buf); if (snum == WNNSERVER_C) w2y (yomi_buf); - m2w (XSTRING (kanji)->_data, kanji_buf); - m2w (XSTRING (comment)->_data, comment_buf); + m2w (XSTRING_DATA (kanji), kanji_buf); + m2w (XSTRING_DATA (comment), comment_buf); if (jl_word_add (wnnfns_buf[snum], XINT (dicno), yomi_buf, kanji_buf, - comment_buf, XINT (hinsi), 0) < 0) + comment_buf, XINT (hinsi), 0) < 0) return Qnil; else return Qt; } @@ -992,7 +992,7 @@ Return list of (kanji hinshi freq dic_no serial). if ((snum = check_wnn_server_type ()) == -1) return Qnil; lb = lb_wnn_server_type[snum]; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (yomi)->_data, wbuf); + m2w (XSTRING_DATA (yomi), wbuf); if (snum == WNNSERVER_C) w2y (wbuf); if ((count = jl_word_search_by_env (wnnfns_buf[snum], @@ -1080,7 +1080,7 @@ or wnn_kaikakko and the CDR contains the value. CHECK_INT (val); setval = XINT (val); if (EQ (key, Qwnn_n)) param.n = setval; - else if (EQ (key, Qwnn_nsho)) param.nsho = setval; + else if (EQ (key, Qwnn_nsho)) param.nsho = setval; else if (EQ (key, Qwnn_hindo)) param.p1 = setval; else if (EQ (key, Qwnn_len)) param.p2 = setval; else if (EQ (key, Qwnn_jiri)) param.p3 = setval; @@ -1106,21 +1106,21 @@ or wnn_kaikakko and the CDR contains the value. #if 0 printf("wnn_n = %d\n",param.n); printf("wnn_nsho = %d\n",param.nsho); - printf("wnn_hindo = %d\n",param.p1); - printf("wnn_len = %d\n",param.p2); - printf("wnn_jiri = %d\n",param.p3); - printf("wnn_flag = %d\n",param.p4); - printf("wnn_jisho = %d\n",param.p5); - printf("wnn_sbn = %d\n",param.p6); - printf("wnn_dbn_len = %d\n",param.p7); - printf("wnn_sbn_cnt = %d\n",param.p8); - printf("wnn_suuji = %d\n",param.p9); - printf("wnn_kana = %d\n",param.p10); - printf("wnn_eisuu = %d\n",param.p11); - printf("wnn_kigou = %d\n",param.p12); - printf("wnn_toji_kakko = %d\n",param.p13); - printf("wnn_fuzokogo = %d\n",param.p14); - printf("wnn_kaikakko = %d\n",param.p15); + printf("wnn_hindo = %d\n",param.p1); + printf("wnn_len = %d\n",param.p2); + printf("wnn_jiri = %d\n",param.p3); + printf("wnn_flag = %d\n",param.p4); + printf("wnn_jisho = %d\n",param.p5); + printf("wnn_sbn = %d\n",param.p6); + printf("wnn_dbn_len = %d\n",param.p7); + printf("wnn_sbn_cnt = %d\n",param.p8); + printf("wnn_suuji = %d\n",param.p9); + printf("wnn_kana = %d\n",param.p10); + printf("wnn_eisuu = %d\n",param.p11); + printf("wnn_kigou = %d\n",param.p12); + printf("wnn_toji_kakko = %d\n",param.p13); + printf("wnn_fuzokogo = %d\n",param.p14); + printf("wnn_kaikakko = %d\n",param.p15); #endif rc = jl_param_set (wnnfns_buf[snum], ¶m); @@ -1175,7 +1175,7 @@ For Wnn. CHECK_STRING (file); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING (file)->_data) < 0) + if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING_DATA (file)) < 0) return Qnil; return Qt; } @@ -1246,7 +1246,7 @@ For Wnn. if ((snum = check_wnn_server_type ()) == -1) return Qnil; lb = lb_wnn_server_type[snum]; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (name)->_data, wbuf); + m2w (XSTRING_DATA (name), wbuf); if ((cnt = jl_hinsi_list (wnnfns_buf[snum], XINT (dicno), wbuf, &area)) < 0) return Qnil; if (cnt == 0) return make_int (0); @@ -1289,21 +1289,21 @@ Specify password files of dictionary and frequency, PW1 and PW2, if needed. int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); - if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]); + if (! NILP (args[3])) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if(jl_fi_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, - XSTRING(args[1])->_data, - WNN_FI_SYSTEM_DICT, - WNN_DIC_RDONLY, - (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - 0, - (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data, - yes_or_no, - puts2 ) < 0) { + XSTRING_DATA (args[0]), + XSTRING_DATA (args[1]), + WNN_FI_SYSTEM_DICT, + WNN_DIC_RDONLY, + NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + 0, + NILP (args[3]) ? 0 : XSTRING_DATA (args[3]), + yes_or_no, + puts2 ) < 0) { UNGCPRO; return Qnil; } @@ -1322,22 +1322,22 @@ Specify password files of dictionary and frequency, PW1 and PW2, if needed. int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); - if (!EQ(args[4], Qnil)) CHECK_STRING (args[4]); - if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]); + if (! NILP (args[4])) CHECK_STRING (args[4]); + if (! NILP (args[5])) CHECK_STRING (args[5]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if(jl_fi_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, - XSTRING(args[1])->_data, - WNN_FI_USER_DICT, - (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[4], Qnil)) ? 0 : XSTRING(args[4])->_data, - (EQ(args[5], Qnil)) ? 0 : XSTRING(args[5])->_data, - yes_or_no, - puts2 ) < 0) { + XSTRING_DATA (args[0]), + XSTRING_DATA (args[1]), + WNN_FI_USER_DICT, + NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[3]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[4]) ? 0 : XSTRING_DATA (args[4]), + NILP (args[5]) ? 0 : XSTRING_DATA (args[5]), + yes_or_no, + puts2 ) < 0) { UNGCPRO; return Qnil; } @@ -1359,7 +1359,7 @@ Specify password files of dictionary and frequency PW1 if needed. struct wnn_henkan_env henv; CHECK_STRING (args[0]); CHECK_INT (args[1]); - if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]); + if (! NILP (args[3])) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); @@ -1371,12 +1371,12 @@ Specify password files of dictionary and frequency PW1 if needed. dic_no = js_get_autolearning_dic(cur_env, WNN_MUHENKAN_LEARNING); if (dic_no == WNN_NO_LEARNING) { if((dic_no = jl_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, + XSTRING_DATA (args[0]), 0, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT(args[1]), WNN_DIC_RW, WNN_DIC_RW, - (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data, + NILP (args[3]) ? 0 : XSTRING_DATA (args[3]), 0, yes_or_no, puts2)) < 0) { @@ -1393,7 +1393,7 @@ Specify password files of dictionary and frequency PW1 if needed. } } vmask |= WNN_ENV_MUHENKAN_LEARN_MASK; - henv.muhenkan_flag = (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW; + henv.muhenkan_flag = NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) { @@ -1418,7 +1418,7 @@ Specify password files of dictionary and frequency PW1 if needed. struct wnn_henkan_env henv; CHECK_STRING (args[0]); CHECK_INT (args[1]); - if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]); + if (! NILP (args[3])) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); @@ -1430,12 +1430,12 @@ Specify password files of dictionary and frequency PW1 if needed. dic_no = js_get_autolearning_dic(cur_env, WNN_BUNSETSUGIRI_LEARNING); if (dic_no == WNN_NO_LEARNING) { if((dic_no = jl_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, + XSTRING_DATA (args[0]), 0, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT(args[1]), WNN_DIC_RW, WNN_DIC_RW, - (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data, + NILP (args[3]) ? 0 : XSTRING_DATA (args[3]), 0, yes_or_no, puts2)) < 0) { @@ -1452,7 +1452,7 @@ Specify password files of dictionary and frequency PW1 if needed. } } vmask |= WNN_ENV_BUNSETSUGIRI_LEARN_MASK; - henv.bunsetsugiri_flag = (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW; + henv.bunsetsugiri_flag = NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) { @@ -1473,8 +1473,8 @@ For FI-Wnn. struct wnn_henkan_env henv; if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; - vmask |= WNN_ENV_LAST_IS_FIRST_MASK; - henv.last_is_first_flag = (EQ(mode, Qnil)) ? False : True; + vmask |= WNN_ENV_LAST_IS_FIRST_MASK; + henv.last_is_first_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1492,7 +1492,7 @@ For FI-Wnn. if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_COMPLEX_CONV_MASK; - henv.complex_flag = (EQ(mode, Qnil)) ? False : True; + henv.complex_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1510,7 +1510,7 @@ For FI-Wnn. if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_OKURI_LEARN_MASK; - henv.okuri_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.okuri_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1553,7 +1553,7 @@ For FI-Wnn. if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_PREFIX_LEARN_MASK; - henv.prefix_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.prefix_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1594,7 +1594,7 @@ For FI-Wnn. if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_SUFFIX_LEARN_MASK; - henv.suffix_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.suffix_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1612,7 +1612,7 @@ For FI-Wnn. if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_COMMON_LAERN_MASK; - henv.common_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.common_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1728,7 +1728,7 @@ For FI-Wnn. if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_YURAGI_MASK; - henv.yuragi_flag = (EQ(mode, Qnil)) ? False : True; + henv.yuragi_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1778,7 +1778,7 @@ For Wnn. CHECK_STRING (name); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (name)->_data, w_buf); + m2w (XSTRING_DATA (name), w_buf); if ((no = jl_hinsi_number (wnnfns_buf[snum], w_buf)) < 0) return Qnil; return make_int (no); } @@ -1926,7 +1926,7 @@ w2m (w_char *wp, unsigned char *mp, unsigned char lb) if (EQ(Vwnn_server_type, Qcserver)) { len = cwnn_yincod_pzy (pzy, wc, - (EQ(Vcwnn_zhuyin, Qnil)) + NILP (Vcwnn_zhuyin) ? CWNN_PINYIN : CWNN_ZHUYIN); for (i = 0; i < len; i++) @@ -1972,7 +1972,7 @@ void m2w (unsigned char *mp, w_char *wp) { unsigned int ch; - + while ((ch = *mp++) != 0) { if (BUFBYTE_LEADING_BYTE_P (ch)) @@ -2032,7 +2032,7 @@ w2y (w_char *w) w++; pin++; } len = cwnn_pzy_yincod (ybuf, pbuf, - (EQ(Vcwnn_zhuyin, Qnil)) ? CWNN_PINYIN : CWNN_ZHUYIN); + NILP (Vcwnn_zhuyin) ? CWNN_PINYIN : CWNN_ZHUYIN); if (len <= 0) return; diff --git a/src/nas.c b/src/nas.c index 0c7f428..b8abdfc 100644 --- a/src/nas.c +++ b/src/nas.c @@ -55,20 +55,19 @@ #ifdef emacs #include #include "lisp.h" +#include "sysdep.h" +#include "syssignal.h" #endif -#if __STDC__ || defined (STDC_HEADERS) -# include -# include -# include -#endif +#include +#include +#include +#include #ifdef HAVE_UNISTD_H #include #endif -#include -#include "syssignal.h" #undef LITTLE_ENDIAN #undef BIG_ENDIAN diff --git a/src/nt.c b/src/nt.c index b7b0362..e9d2961 100644 --- a/src/nt.c +++ b/src/nt.c @@ -1169,7 +1169,7 @@ sys_rename (const char * oldname, const char * newname) return -1; } - /* Emulate Unix behaviour - newname is deleted if it already exists + /* Emulate Unix behavior - newname is deleted if it already exists (at least if it is a file; don't do this for directories). However, don't do this if we are just changing the case of the file name - we will end up deleting the file we are trying to rename! */ @@ -1288,7 +1288,7 @@ generate_inode_val (const char * name) unsigned hash; /* Get the truly canonical filename, if it exists. (Note: this - doesn't resolve aliasing due to subst commands, or recognise hard + doesn't resolve aliasing due to subst commands, or recognize hard links. */ if (!win32_get_long_filename ((char *)name, fullname, MAX_PATH)) abort (); @@ -1390,8 +1390,8 @@ stat (const char * path, struct stat * buf) } else if (!NILP (Vmswindows_get_true_file_attributes)) { - /* This is more accurate in terms of gettting the correct number - of links, but is quite slow (it is noticable when Emacs is + /* This is more accurate in terms of getting the correct number + of links, but is quite slow (it is noticeable when Emacs is making a list of file name completions). */ BY_HANDLE_FILE_INFORMATION info; @@ -1833,7 +1833,7 @@ int msw_raise (int nsig) */ const int timer_prec = 10; -/* Last itimevals, as set by calls to setitimer */ +/* Last itimervals, as set by calls to setitimer */ static struct itimerval it_alarm; static struct itimerval it_prof; @@ -1863,7 +1863,7 @@ static UINT period (const struct itimerval* it, UINT denom) if (tv->tv_sec == 0 && tv->tv_usec == 0) return 0; - /* Conver to ms and divide by denom */ + /* Convert to ms and divide by denom */ res = (tv->tv_sec * 1000 + (tv->tv_usec + 500) / 1000) / denom; /* Converge to minimum timer resolution */ diff --git a/src/ntheap.c b/src/ntheap.c index be34002..5202196 100644 --- a/src/ntheap.c +++ b/src/ntheap.c @@ -111,7 +111,7 @@ get_data_end (void) static char * allocate_heap (void) { - /* The base address for our GNU malloc heap is chosen in conjuction + /* The base address for our GNU malloc heap is chosen in conjunction with the link settings for temacs.exe which control the stack size, the initial default process heap size and the executable image base address. The link settings and the malloc heap base below must all diff --git a/src/ntproc.c b/src/ntproc.c index bbfefee..aee5649 100644 --- a/src/ntproc.c +++ b/src/ntproc.c @@ -58,7 +58,7 @@ Boston, MA 02111-1307, USA. /* Control whether spawnve quotes arguments as necessary to ensure correct parsing by child process. Because not all uses of spawnve - are careful about constructing argv arrays, we make this behaviour + are careful about constructing argv arrays, we make this behavior conditional (off by default). */ Lisp_Object Vwin32_quote_process_args; @@ -620,7 +620,7 @@ sys_spawnve (int mode, CONST char *cmdname, The Win32 GNU-based library from Cygnus doubles quotes to escape them, while MSVC uses backslash for escaping. (Actually the MSVC - startup code does attempt to recognise doubled quotes and accept + startup code does attempt to recognize doubled quotes and accept them, but gets it wrong and ends up requiring three quotes to get a single embedded quote!) So by default we decide whether to use quote or backslash as the escape character based on whether the @@ -628,7 +628,7 @@ sys_spawnve (int mode, CONST char *cmdname, Note that using backslash to escape embedded quotes requires additional special handling if an embedded quote is already - preceeded by backslash, or if an arg requiring quoting ends with + preceded by backslash, or if an arg requiring quoting ends with backslash. In such cases, the run of escape characters needs to be doubled. For consistency, we apply this special handling as long as the escape character is not quote. @@ -724,7 +724,7 @@ sys_spawnve (int mode, CONST char *cmdname, #if 0 /* This version does not escape quotes if they occur at the beginning or end of the arg - this could lead to incorrect - behaviour when the arg itself represents a command line + behavior when the arg itself represents a command line containing quoted args. I believe this was originally done as a hack to make some things work, before `win32-quote-process-args' was added. */ @@ -1193,7 +1193,7 @@ If successful, the return value is t, otherwise nil. DEFUN ("win32-get-locale-info", Fwin32_get_locale_info, 1, 2, "", /* "Return information about the Windows locale LCID. By default, return a three letter locale code which encodes the default -language as the first two characters, and the country or regionial variant +language as the first two characters, and the country or regional variant as the third letter. For example, ENU refers to `English (United States)', while ENC means `English (Canadian)'. @@ -1395,7 +1395,7 @@ process temporarily). A value of zero disables waiting entirely. "Non-nil means attempt to fake realistic inode values. This works by hashing the truename of files, and should detect aliasing between long and short (8.3 DOS) names, but can have -false positives because of hash collisions. Note that determing +false positives because of hash collisions. Note that determining the truename of a file can be slow. */ ); Vwin32_generate_fake_inodes = Qnil; diff --git a/src/objects-msw.c b/src/objects-msw.c index 20f2c75..5ef4393 100644 --- a/src/objects-msw.c +++ b/src/objects-msw.c @@ -1060,7 +1060,7 @@ mswindows_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object COLOR_INSTANCE_MSWINDOWS_COLOR (c) = color; return 1; } - maybe_signal_simple_error ("unrecognized color", name, Qcolor, errb); + maybe_signal_simple_error ("Unrecognized color", name, Qcolor, errb); return(0); } diff --git a/src/objects-tty.c b/src/objects-tty.c index 513349d..7e02318 100644 --- a/src/objects-tty.c +++ b/src/objects-tty.c @@ -171,7 +171,7 @@ static void tty_mark_color_instance (struct Lisp_Color_Instance *c, void (*markobj) (Lisp_Object)) { - ((markobj) (COLOR_INSTANCE_TTY_SYMBOL (c))); + markobj (COLOR_INSTANCE_TTY_SYMBOL (c)); } static void @@ -259,7 +259,7 @@ static void tty_mark_font_instance (struct Lisp_Font_Instance *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FONT_INSTANCE_TTY_CHARSET (f))); + markobj (FONT_INSTANCE_TTY_CHARSET (f)); } static void diff --git a/src/objects-x.c b/src/objects-x.c index bc27fef..29d51cf 100644 --- a/src/objects-x.c +++ b/src/objects-x.c @@ -114,7 +114,7 @@ allocate_nearest_color (Display *display, Colormap colormap, Visual *visual, status = 1; else { - int rd, gr, bl; + int rd, gr, bl; /* ### JH: I'm punting here, knowing that doing this will at least draw the color correctly. However, unless we convert all of the functions that allocate colors (graphics @@ -209,13 +209,11 @@ x_parse_nearest_color (struct device *d, XColor *color, Bufbyte *name, Bytecount len, Error_behavior errb) { Display *dpy; - Screen *xs; Colormap cmap; Visual *visual; int result; dpy = DEVICE_X_DISPLAY (d); - xs = DefaultScreenOfDisplay (dpy); cmap = DEVICE_X_COLORMAP(d); visual = DEVICE_X_VISUAL (d); @@ -229,14 +227,14 @@ x_parse_nearest_color (struct device *d, XColor *color, Bufbyte *name, } if (!result) { - maybe_signal_simple_error ("unrecognized color", make_string (name, len), + maybe_signal_simple_error ("Unrecognized color", make_string (name, len), Qcolor, errb); return 0; } result = allocate_nearest_color (dpy, cmap, visual, color); if (!result) { - maybe_signal_simple_error ("couldn't allocate color", + maybe_signal_simple_error ("Couldn't allocate color", make_string (name, len), Qcolor, errb); return 0; } @@ -367,7 +365,7 @@ x_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name, if (!xf) { - maybe_signal_simple_error ("couldn't load font", f->name, + maybe_signal_simple_error ("Couldn't load font", f->name, Qfont, errb); return 0; } @@ -452,7 +450,7 @@ static void x_mark_font_instance (struct Lisp_Font_Instance *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FONT_INSTANCE_X_TRUENAME (f))); + markobj (FONT_INSTANCE_X_TRUENAME (f)); } static void @@ -498,7 +496,7 @@ x_finalize_font_instance (struct Lisp_Font_Instance *f) also picking 100dpi adobe fonts over 75dpi adobe fonts even though the 75dpi are in the path earlier) but sometimes appears to be doing something else entirely (for example, removing the bitsream fonts from the path will - cause the 75dpi adobe fonts to be used instead of the100dpi, even though + cause the 75dpi adobe fonts to be used instead of the 100dpi, even though their relative positions in the path (and their names!) have not changed). The documentation for XSetFontPath() seems to indicate that the order of @@ -509,7 +507,7 @@ x_finalize_font_instance (struct Lisp_Font_Instance *f) truename of the font. However, there are two problems with using this: the first is that the X Protocol Document is quite explicit that all properties are optional, so we can't depend on it being there. The second is that - it's concievable that this alleged truename isn't actually accessible as a + it's conceivable that this alleged truename isn't actually accessible as a font, due to some difference of opinion between the font designers and whoever installed the font on the system. @@ -566,7 +564,7 @@ x_finalize_font_instance (struct Lisp_Font_Instance *f) static int valid_x_font_name_p (Display *dpy, char *name) { - /* Maybe this should be implemented by callign XLoadFont and trapping + /* Maybe this should be implemented by calling XLoadFont and trapping the error. That would be a lot of work, and wasteful as hell, but might be more correct. */ @@ -783,7 +781,7 @@ x_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb) Lisp_Object font_instance; XSETFONT_INSTANCE (font_instance, f); - maybe_signal_simple_error ("couldn't determine font truename", + maybe_signal_simple_error ("Couldn't determine font truename", font_instance, Qfont, errb); /* Ok, just this once, return the font name as the truename. (This is only used by Fequal() right now.) */ diff --git a/src/objects.c b/src/objects.c index 4161718..10f5cf7 100644 --- a/src/objects.c +++ b/src/objects.c @@ -60,7 +60,7 @@ static Lisp_Object mark_color_instance (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); - ((markobj) (c->name)); + markobj (c->name); if (!NILP (c->device)) /* Vthe_null_color_instance */ MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c, markobj)); @@ -100,18 +100,16 @@ finalize_color_instance (void *header, int for_disksave) } static int -color_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth) +color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (o1); - struct Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (o2); - struct device *d1 = DEVICEP (c1->device) ? XDEVICE (c1->device) : 0; - struct device *d2 = DEVICEP (c2->device) ? XDEVICE (c2->device) : 0; - - if (d1 != d2) - return 0; - if (!d1 || !HAS_DEVMETH_P (d1, color_instance_equal)) - return EQ (o1, o2); - return DEVMETH (d1, color_instance_equal, (c1, c2, depth)); + struct Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1); + struct Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (obj2); + + return (c1 == c2) || + ((EQ (c1->device, c2->device)) && + DEVICEP (c1->device) && + HAS_DEVMETH_P (XDEVICE (c1->device), color_instance_equal) && + DEVMETH (XDEVICE (c1->device), color_instance_equal, (c1, c2, depth))); } static unsigned long @@ -243,7 +241,7 @@ mark_font_instance (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Font_Instance *f = XFONT_INSTANCE (obj); - ((markobj) (f->name)); + markobj (f->name); if (!NILP (f->device)) /* Vthe_null_font_instance */ MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f, markobj)); @@ -284,11 +282,11 @@ finalize_font_instance (void *header, int for_disksave) this means the `equal' could cause XListFonts to be run the first time. */ static int -font_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth) +font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { /* #### should this be moved into a device method? */ - return internal_equal (font_instance_truename_internal (o1, ERROR_ME_NOT), - font_instance_truename_internal (o2, ERROR_ME_NOT), + return internal_equal (font_instance_truename_internal (obj1, ERROR_ME_NOT), + font_instance_truename_internal (obj2, ERROR_ME_NOT), depth + 1); } @@ -483,8 +481,8 @@ color_mark (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); - ((markobj) (COLOR_SPECIFIER_FACE (color))); - ((markobj) (COLOR_SPECIFIER_FACE_PROPERTY (color))); + markobj (COLOR_SPECIFIER_FACE (color)); + markobj (COLOR_SPECIFIER_FACE_PROPERTY (color)); } /* No equal or hash methods; ignore the face the color is based off @@ -499,7 +497,6 @@ color_instantiate (Lisp_Object specifier, Lisp_Object matchspec, so we can freely error. */ Lisp_Object device = DFW_DEVICE (domain); struct device *d = XDEVICE (device); - Lisp_Object instance; if (COLOR_INSTANCEP (instantiator)) { @@ -516,7 +513,8 @@ color_instantiate (Lisp_Object specifier, Lisp_Object matchspec, if (STRINGP (instantiator)) { /* First, look to see if we can retrieve a cached value. */ - instance = Fgethash (instantiator, d->color_instance_cache, Qunbound); + Lisp_Object instance = + Fgethash (instantiator, d->color_instance_cache, Qunbound); /* Otherwise, make a new one. */ if (UNBOUNDP (instance)) { @@ -661,8 +659,8 @@ font_mark (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Specifier *font = XFONT_SPECIFIER (obj); - ((markobj) (FONT_SPECIFIER_FACE (font))); - ((markobj) (FONT_SPECIFIER_FACE_PROPERTY (font))); + markobj (FONT_SPECIFIER_FACE (font)); + markobj (FONT_SPECIFIER_FACE_PROPERTY (font)); } /* No equal or hash methods; ignore the face the font is based off @@ -736,17 +734,17 @@ font_instantiate (Lisp_Object specifier, Lisp_Object matchspec, iterate over all possible fonts, and a regexp match on each one. So we cache the results. */ Lisp_Object matching_font = Qunbound; - Lisp_Object hashtab = Fgethash (matchspec, d->charset_font_cache, + Lisp_Object hash_table = Fgethash (matchspec, d->charset_font_cache, Qunbound); - if (UNBOUNDP (hashtab)) + if (UNBOUNDP (hash_table)) { /* need to make a sub hash table. */ - hashtab = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQUAL); - Fputhash (matchspec, hashtab, d->charset_font_cache); + hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, + HASH_TABLE_EQUAL); + Fputhash (matchspec, hash_table, d->charset_font_cache); } else - matching_font = Fgethash (instantiator, hashtab, Qunbound); + matching_font = Fgethash (instantiator, hash_table, Qunbound); if (UNBOUNDP (matching_font)) { @@ -755,7 +753,7 @@ font_instantiate (Lisp_Object specifier, Lisp_Object matchspec, DEVMETH_OR_GIVEN (d, find_charset_font, (device, instantiator, matchspec), instantiator); - Fputhash (instantiator, matching_font, hashtab); + Fputhash (instantiator, matching_font, hash_table); } if (NILP (matching_font)) return Qunbound; @@ -868,8 +866,8 @@ face_boolean_mark (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); - ((markobj) (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean))); - ((markobj) (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean))); + markobj (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); + markobj (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); } /* No equal or hash methods; ignore the face the face-boolean is based off diff --git a/src/offix.c b/src/offix.c index 90a157b..42a5cfa 100644 --- a/src/offix.c +++ b/src/offix.c @@ -316,7 +316,7 @@ DndSetData(int Type,unsigned char *Data,unsigned long Size) } /*================================================================== DndGetData - * Return a pointer to the current data. Se HOWTO for more details. + * Return a pointer to the current data. See HOWTO for more details. *===========================================================================*/ void DndGetData(XEvent *event, unsigned char **Data,unsigned long *Size) diff --git a/src/opaque.c b/src/opaque.c index f02b7ed..d15bac5 100644 --- a/src/opaque.c +++ b/src/opaque.c @@ -42,6 +42,7 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" #include "opaque.h" +#include Lisp_Object Qopaquep; @@ -55,62 +56,76 @@ Lisp_Object Vopaque_ptr_free_list; static Lisp_Object mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object)) { + Lisp_Opaque *p = XOPAQUE (obj); + Lisp_Object size_or_chain = p->size_or_chain; #ifdef ERROR_CHECK_GC if (!in_opaque_list_marking) /* size is non-int for objects on an opaque free list. We sure as hell better not be marking any of these objects unless we're marking an opaque list. */ - assert (INTP (XOPAQUE (obj)->size_or_chain)); + assert (GC_INTP (size_or_chain)); else /* marking an opaque on the free list doesn't do any recursive markings, so we better not have non-freed opaques on a free list. */ - assert (!INTP (XOPAQUE (obj)->size_or_chain)); + assert (!GC_INTP (size_or_chain)); #endif - if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj)) - return XOPAQUE_MARKFUN (obj) (obj, markobj); + if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p)) + return OPAQUE_MARKFUN (p) (obj, markobj); else - return XOPAQUE (obj)->size_or_chain; + return size_or_chain; } /* Should never, ever be called. (except by an external debugger) */ static void print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { + CONST Lisp_Opaque *p = XOPAQUE (obj); char buf[200]; - if (INTP (XOPAQUE (obj)->size_or_chain)) - sprintf (buf, "#", - (long) XOPAQUE_SIZE (obj), (unsigned long) XPNTR (obj)); + char size_buf[50]; + + if (INTP (p->size_or_chain)) + sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p)); else - sprintf (buf, "#", - (unsigned long) XPNTR (obj)); + sprintf (size_buf, "freed"); + + sprintf (buf, "#", + size_buf, (unsigned long) p); write_c_string (buf, printcharfun); } static size_t sizeof_opaque (CONST void *header) { - CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header; - if (!INTP (p->size_or_chain)) - return sizeof (*p); - return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int); + CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header; + return offsetof (Lisp_Opaque, data) + + (GC_INTP (p->size_or_chain) ? XINT (p->size_or_chain) : 0); } +/* Return an opaque object of size SIZE. + If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes. + If DATA is OPAQUE_UNINIT, the object's data is uninitialized. + Else the object's data is initialized by copying from DATA. */ Lisp_Object -make_opaque (int size, CONST void *data) +make_opaque (size_t size, CONST void *data) { - struct Lisp_Opaque *p = (struct Lisp_Opaque *) - alloc_lcrecord (sizeof (*p) + size - sizeof (int), lrecord_opaque); - Lisp_Object val; - + Lisp_Opaque *p = (Lisp_Opaque *) + alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, lrecord_opaque); p->markfun = 0; p->size_or_chain = make_int (size); - if (data) - memcpy (p->data, data, size); + + if (data == OPAQUE_CLEAR) + memset (p->data, '\0', size); + else if (data == OPAQUE_UNINIT) + DO_NOTHING; else - memset (p->data, 0, size); - XSETOPAQUE (val, p); - return val; + memcpy (p->data, data, size); + + { + Lisp_Object val; + XSETOPAQUE (val, p); + return val; + } } /* This will not work correctly for opaques with subobjects! */ @@ -118,17 +133,14 @@ make_opaque (int size, CONST void *data) static int equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth) { + size_t size; #ifdef DEBUG_XEMACS assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2)); - assert (INTP (XOPAQUE(obj1)->size_or_chain)); - assert (INTP (XOPAQUE(obj2)->size_or_chain)); + assert (INTP (XOPAQUE (obj1)->size_or_chain)); + assert (INTP (XOPAQUE (obj2)->size_or_chain)); #endif - if (XOPAQUE_SIZE(obj1) != XOPAQUE_SIZE(obj2)) - return 0; - return (XOPAQUE_SIZE(obj1) == sizeof(*XOPAQUE_DATA(obj1)) - ? *XOPAQUE_DATA(obj1) == *XOPAQUE_DATA(obj2) - : memcmp (XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2), - XOPAQUE_SIZE(obj1)) == 0); + return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) && + !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size)); } /* This will not work correctly for opaques with subobjects! */ @@ -138,36 +150,36 @@ hash_opaque (Lisp_Object obj, int depth) { #ifdef DEBUG_XEMACS assert (!XOPAQUE_MARKFUN (obj)); - assert (INTP (XOPAQUE(obj)->size_or_chain)); + assert (INTP (XOPAQUE (obj)->size_or_chain)); #endif - if (XOPAQUE_SIZE(obj) == sizeof (unsigned long)) - return (unsigned int) *XOPAQUE_DATA(obj); + if (XOPAQUE_SIZE (obj) == sizeof (unsigned long)) + return *((unsigned long *) XOPAQUE_DATA(obj)); else - return memory_hash (XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj)); + return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj)); } DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, mark_opaque, print_opaque, 0, equal_opaque, hash_opaque, - sizeof_opaque, struct Lisp_Opaque); + sizeof_opaque, Lisp_Opaque); static Lisp_Object mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) { in_opaque_list_marking++; - (markobj) (XOPAQUE_LIST (obj)->free); + markobj (XOPAQUE_LIST (obj)->free); in_opaque_list_marking--; return Qnil; } Lisp_Object -make_opaque_list (int size, +make_opaque_list (size_t size, Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object))) { Lisp_Object val; - struct Lisp_Opaque_List *p = - alloc_lcrecord_type (struct Lisp_Opaque_List, lrecord_opaque_list); + Lisp_Opaque_List *p = + alloc_lcrecord_type (Lisp_Opaque_List, lrecord_opaque_list); p->markfun = markfun; p->size = size; @@ -178,12 +190,12 @@ make_opaque_list (int size, DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list, mark_opaque_list, internal_object_printer, - 0, 0, 0, struct Lisp_Opaque_List); + 0, 0, 0, Lisp_Opaque_List); Lisp_Object allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data) { - struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); + Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); Lisp_Object val; if (!NILP (li->free)) @@ -208,7 +220,7 @@ allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data) void free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque) { - struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); + Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); #ifdef ERROR_CHECK_GC assert (INTP (XOPAQUE (opaque)->size_or_chain)); @@ -226,7 +238,7 @@ make_opaque_ptr (CONST void *val) (CONST void *) &val); } -/* Be wery wery careful with this. Same admonitions as with +/* Be very very careful with this. Same admonitions as with free_cons() apply. */ void diff --git a/src/opaque.h b/src/opaque.h index 5a711e7..e9ddf0a 100644 --- a/src/opaque.h +++ b/src/opaque.h @@ -26,29 +26,34 @@ Boston, MA 02111-1307, USA. */ #ifndef _XEMACS_OPAQUE_H_ #define _XEMACS_OPAQUE_H_ -struct Lisp_Opaque +typedef union { + struct { Lisp_Object obj; } obj; + struct { void *p; } p; + struct { double d; } d; +} max_align_t; + +typedef struct Lisp_Opaque { struct lcrecord_header header; Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object)); /* An integral size for non-freed objects, an opaque or nil for freed objects. */ Lisp_Object size_or_chain; - /* It's actually more space-efficient to declare this as an int - rather than a char, because the structure will get rounded up - in size by the compiler anyway. */ - int data[1]; -}; + max_align_t data[1]; +} Lisp_Opaque; -struct Lisp_Opaque_List +typedef struct Lisp_Opaque_List { struct lcrecord_header header; + /* `markfun' allows you to put lisp objects inside of opaque objects + without having to create a new object type. */ Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object)); Lisp_Object free; - int size; -}; + size_t size; +} Lisp_Opaque_List; -DECLARE_LRECORD (opaque, struct Lisp_Opaque); -#define XOPAQUE(x) XRECORD (x, opaque, struct Lisp_Opaque) +DECLARE_LRECORD (opaque, Lisp_Opaque); +#define XOPAQUE(x) XRECORD (x, opaque, Lisp_Opaque) #define XSETOPAQUE(x, p) XSETRECORD (x, p, opaque) #define OPAQUEP(x) RECORDP (x, opaque) #define GC_OPAQUEP(x) GC_RECORDP (x, opaque) @@ -56,8 +61,8 @@ DECLARE_LRECORD (opaque, struct Lisp_Opaque); Opaque pointers should never escape to the Lisp level, so functions should not be doing this. */ -DECLARE_LRECORD (opaque_list, struct Lisp_Opaque_List); -#define XOPAQUE_LIST(x) XRECORD (x, opaque_list, struct Lisp_Opaque_List) +DECLARE_LRECORD (opaque_list, Lisp_Opaque_List); +#define XOPAQUE_LIST(x) XRECORD (x, opaque_list, Lisp_Opaque_List) #define XSETOPAQUE_LIST(x, p) XSETRECORD (x, p, opaque_list) #define OPAQUE_LISTP(x) RECORDP (x, opaque_list) #define GC_OPAQUE_LISTP(x) GC_RECORDP (x, opaque_list) @@ -65,14 +70,18 @@ DECLARE_LRECORD (opaque_list, struct Lisp_Opaque_List); Opaque lists should never escape to the Lisp level, so functions should not be doing this. */ -Lisp_Object make_opaque (int size, CONST void *data); +/* Alternative DATA arguments to make_opaque */ +#define OPAQUE_CLEAR ((CONST void *) 0) +#define OPAQUE_UNINIT ((CONST void *) -1) + +Lisp_Object make_opaque (size_t size, CONST void *data); Lisp_Object make_opaque_ptr (CONST void *val); Lisp_Object make_opaque_long (long val); void free_opaque_ptr (Lisp_Object ptr); #define OPAQUE_SIZE(op) XINT ((op)->size_or_chain) #define OPAQUE_DATA(op) ((op)->data) -#define OPAQUE_MARKFUN(op) ((op)->markfun) /* What's the point if this? */ +#define OPAQUE_MARKFUN(op) ((op)->markfun) #define XOPAQUE_SIZE(op) OPAQUE_SIZE (XOPAQUE (op)) #define XOPAQUE_DATA(op) OPAQUE_DATA (XOPAQUE (op)) #define XOPAQUE_MARKFUN(op) OPAQUE_MARKFUN (XOPAQUE (op)) @@ -83,7 +92,7 @@ void free_opaque_ptr (Lisp_Object ptr); #define set_opaque_long(op, ptr) (get_opaque_long (op) = ptr) #define set_opaque_markfun(op, fun) (XOPAQUE_MARKFUN (op) = fun) -Lisp_Object make_opaque_list (int size, +Lisp_Object make_opaque_list (size_t size, Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object))); diff --git a/src/print.c b/src/print.c index 480cf9c..a32b249 100644 --- a/src/print.c +++ b/src/print.c @@ -39,6 +39,7 @@ Boston, MA 02111-1307, USA. */ #include "lstream.h" #include "sysfile.h" +#include #include /* Define if not in float.h */ #ifndef DBL_DIG @@ -166,7 +167,7 @@ output_string (Lisp_Object function, CONST Bufbyte *nonreloc, CONST Bufbyte *newnonreloc = nonreloc; struct gcpro gcpro1, gcpro2; - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return; /* Perhaps not necessary but probably safer. */ @@ -278,7 +279,7 @@ canonicalize_printcharfun (Lisp_Object printcharfun) static Lisp_Object print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) { - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return Qnil; @@ -323,7 +324,7 @@ print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) static void print_finish (Lisp_Object stream, Lisp_Object frame_kludge) { - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return; @@ -341,7 +342,7 @@ print_finish (Lisp_Object stream, Lisp_Object frame_kludge) clear_echo_area_from_print (f, Qnil, 1); echo_area_append (f, resizing_buffer_stream_ptr (str), Qnil, 0, Lstream_byte_count (str), - Vprint_message_label); + Vprint_message_label); Lstream_delete (str); } } @@ -395,7 +396,7 @@ STREAM defaults to the value of `standard-output' (which see). } void -temp_output_buffer_setup (CONST char *bufname) +temp_output_buffer_setup (Lisp_Object bufname) { /* This function can GC */ struct buffer *old = current_buffer; @@ -406,7 +407,7 @@ temp_output_buffer_setup (CONST char *bufname) so that proper translation on the buffer name can occur. */ #endif - Fset_buffer (Fget_buffer_create (build_string (bufname))); + Fset_buffer (Fget_buffer_create (bufname)); current_buffer->read_only = Qnil; Ferase_buffer (Qnil); @@ -418,7 +419,7 @@ temp_output_buffer_setup (CONST char *bufname) } Lisp_Object -internal_with_output_to_temp_buffer (CONST char *bufname, +internal_with_output_to_temp_buffer (Lisp_Object bufname, Lisp_Object (*function) (Lisp_Object arg), Lisp_Object arg, Lisp_Object same_frame) @@ -429,7 +430,7 @@ internal_with_output_to_temp_buffer (CONST char *bufname, GCPRO3 (buf, arg, same_frame); - temp_output_buffer_setup (GETTEXT (bufname)); + temp_output_buffer_setup (bufname); buf = Vstandard_output; arg = (*function) (arg); @@ -454,21 +455,22 @@ to get the buffer displayed. It gets one argument, the buffer to display. (args)) { /* This function can GC */ - struct gcpro gcpro1; - Lisp_Object name; + Lisp_Object name = Qnil; int speccount = specpdl_depth (); - Lisp_Object val; + struct gcpro gcpro1, gcpro2; + Lisp_Object val = Qnil; #ifdef I18N3 /* #### should set the buffer to be translating. See print_internal(). */ #endif - GCPRO1 (args); + GCPRO2 (name, val); name = Feval (XCAR (args)); - UNGCPRO; CHECK_STRING (name); - temp_output_buffer_setup ((char *) XSTRING_DATA (name)); + + temp_output_buffer_setup (name); + UNGCPRO; val = Fprogn (XCDR (args)); @@ -896,23 +898,33 @@ print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) write_char_internal ("(", printcharfun); { - int i = 0; - int max = 0; - - if (INTP (Vprint_length)) - max = XINT (Vprint_length); - while (CONSP (obj)) + int len; + int max = INTP (Vprint_length) ? XINT (Vprint_length) : INT_MAX; + Lisp_Object tortoise; + /* Use tortoise/hare to make sure circular lists don't infloop */ + + for (tortoise = obj, len = 0; + CONSP (obj); + obj = XCDR (obj), len++) { - if (i++) + if (len > 0) write_char_internal (" ", printcharfun); - if (max && i > max) + if (EQ (obj, tortoise) && len > 0) + { + if (print_readably) + error ("printing unreadable circular list"); + else + write_c_string ("... ", printcharfun); + break; + } + if (len & 1) + tortoise = XCDR (tortoise); + if (len > max) { write_c_string ("...", printcharfun); break; } - print_internal (XCAR (obj), printcharfun, - escapeflag); - obj = XCDR (obj); + print_internal (XCAR (obj), printcharfun, escapeflag); } } if (!LISTP (obj)) @@ -921,6 +933,7 @@ print_cons (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) print_internal (obj, printcharfun, escapeflag); } UNGCPRO; + write_char_internal (")", printcharfun); return; } @@ -1041,7 +1054,7 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) QUIT; - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return; #ifdef I18N3 @@ -1244,79 +1257,6 @@ print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) print_depth--; } -static void -print_compiled_function_internal (CONST char *start, CONST char *end, - Lisp_Object obj, - Lisp_Object printcharfun, int escapeflag) -{ - /* This function can GC */ - struct Lisp_Compiled_Function *b = - XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ - int docp = b->flags.documentationp; - int intp = b->flags.interactivep; - struct gcpro gcpro1, gcpro2; - char buf[100]; - GCPRO2 (obj, printcharfun); - - write_c_string (start, printcharfun); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - if (!print_readably) - { - Lisp_Object ann = compiled_function_annotation (b); - if (!NILP (ann)) - { - write_c_string ("(from ", printcharfun); - print_internal (ann, printcharfun, 1); - write_c_string (") ", printcharfun); - } - } -#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ - /* COMPILED_ARGLIST = 0 */ - print_internal (b->arglist, printcharfun, escapeflag); - /* COMPILED_BYTECODE = 1 */ - write_char_internal (" ", printcharfun); - /* we don't really want to see that junk in the bytecode instructions. */ - if (STRINGP (b->bytecodes) && !print_readably) - { - sprintf (buf, "\"...(%ld)\"", (long) XSTRING_LENGTH (b->bytecodes)); - write_c_string (buf, printcharfun); - } - else - print_internal (b->bytecodes, printcharfun, escapeflag); - /* COMPILED_CONSTANTS = 2 */ - write_char_internal (" ", printcharfun); - print_internal (b->constants, printcharfun, escapeflag); - /* COMPILED_STACK_DEPTH = 3 */ - sprintf (buf, " %d", b->maxdepth); - write_c_string (buf, printcharfun); - /* COMPILED_DOC_STRING = 4 */ - if (docp || intp) - { - write_char_internal (" ", printcharfun); - print_internal (compiled_function_documentation (b), printcharfun, - escapeflag); - } - /* COMPILED_INTERACTIVE = 5 */ - if (intp) - { - write_char_internal (" ", printcharfun); - print_internal (compiled_function_interactive (b), printcharfun, - escapeflag); - } - UNGCPRO; - write_c_string (end, printcharfun); -} - -void -print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, - int escapeflag) -{ - /* This function can GC */ - print_compiled_function_internal (((print_readably) ? "#[" : - "#"), - obj, printcharfun, escapeflag); -} #ifdef LISP_FLOAT_TYPE void @@ -1324,7 +1264,7 @@ print_float (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { char pigbuf[350]; /* see comments in float_to_string */ - float_to_string (pigbuf, float_data (XFLOAT (obj))); + float_to_string (pigbuf, XFLOAT_DATA (obj)); write_c_string (pigbuf, printcharfun); } #endif /* LISP_FLOAT_TYPE */ @@ -1431,17 +1371,22 @@ print_symbol (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) XSETSTRING (nameobj, name); for (i = 0; i < size; i++) { - Bufbyte c = string_byte (name, i); - - if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' || - c == '(' || c == ')' || c == ',' || c =='.' || c == '`' || - c == '[' || c == ']' || c == '?' || c <= 040) + switch (string_byte (name, i)) { + case 0: case 1: case 2: case 3: + case 4: case 5: case 6: case 7: + case 8: case 9: case 10: case 11: + case 12: case 13: case 14: case 15: + case 16: case 17: case 18: case 19: + case 20: case 21: case 22: case 23: + case 24: case 25: case 26: case 27: + case 28: case 29: case 30: case 31: + case ' ': case '\"': case '\\': case '\'': + case ';': case '#' : case '(' : case ')': + case ',': case '.' : case '`' : + case '[': case ']' : case '?' : if (i > last) - { - output_string (printcharfun, 0, nameobj, last, - i - last); - } + output_string (printcharfun, 0, nameobj, last, i - last); write_char_internal ("\\", printcharfun); last = i; } @@ -1614,11 +1559,12 @@ void debug_backtrace (void) { /* This function can GC */ - int old_print_readably = print_readably; - int old_print_depth = print_depth; - Lisp_Object old_print_length = Vprint_length; - Lisp_Object old_print_level = Vprint_level; - Lisp_Object old_inhibit_quit = Vinhibit_quit; + int old_print_readably = print_readably; + int old_print_depth = print_depth; + Lisp_Object old_print_length = Vprint_length; + Lisp_Object old_print_level = Vprint_level; + Lisp_Object old_inhibit_quit = Vinhibit_quit; + struct gcpro gcpro1, gcpro2, gcpro3; GCPRO3 (old_print_level, old_print_length, old_inhibit_quit); @@ -1633,15 +1579,18 @@ debug_backtrace (void) Vprint_length = make_int (debug_print_length); if (debug_print_level > 0) Vprint_level = make_int (debug_print_level); + Fbacktrace (Qexternal_debugging_output, Qt); stderr_out ("\n"); fflush (stderr); - Vinhibit_quit = old_inhibit_quit; - Vprint_level = old_print_level; - Vprint_length = old_print_length; - print_depth = old_print_depth; + + Vinhibit_quit = old_inhibit_quit; + Vprint_level = old_print_level; + Vprint_length = old_print_length; + print_depth = old_print_depth; print_readably = old_print_readably; print_unbuffered--; + UNGCPRO; } @@ -1662,7 +1611,8 @@ debug_short_backtrace (int length) if (COMPILED_FUNCTIONP (*bt->function)) { #if defined(COMPILED_FUNCTION_ANNOTATION_HACK) - Lisp_Object ann = Fcompiled_function_annotation (*bt->function); + Lisp_Object ann = + compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function)); #else Lisp_Object ann = Qnil; #endif diff --git a/src/process-nt.c b/src/process-nt.c index dfe155d..1b1ad26 100644 --- a/src/process-nt.c +++ b/src/process-nt.c @@ -1,4 +1,4 @@ -/* Asynchronous subprocess implemenation for Win32 +/* Asynchronous subprocess implementation for Win32 Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. @@ -45,7 +45,7 @@ Boston, MA 02111-1307, USA. */ /* Bound by winnt.el */ Lisp_Object Qnt_quote_process_args; -/* Implemenation-specific data. Pointed to by Lisp_Process->process_data */ +/* Implementation-specific data. Pointed to by Lisp_Process->process_data */ struct nt_process_data { HANDLE h_process; @@ -382,7 +382,7 @@ nt_finalize_process_data (struct Lisp_Process *p, int for_disksave) } /* - * Initialize XEmacs process implemenation once + * Initialize XEmacs process implementation once */ static void nt_init_process (void) @@ -398,7 +398,7 @@ nt_init_process (void) * object. If this function signals, the caller is responsible for * deleting (and finalizing) the process object. * - * The method must return PID of the new proces, a (positive??? ####) number + * The method must return PID of the new process, a (positive??? ####) number * which fits into Lisp_Int. No return value indicates an error, the method * must signal an error instead. */ @@ -607,7 +607,7 @@ nt_update_status_if_terminated (struct Lisp_Process* p) } /* - * Stuff the entire contents of LSTREAM to the process ouptut pipe + * Stuff the entire contents of LSTREAM to the process output pipe */ /* #### If only this function could be somehow merged with @@ -893,7 +893,7 @@ nt_open_network_stream (Lisp_Object name, Lisp_Object host, Lisp_Object service, if (nsel > 0) { - /* Check was connnection successful or not */ + /* Check: was connection successful or not? */ tv.tv_usec = 0; nsel = select (0, NULL, NULL, &fdset, &tv); if (nsel > 0) diff --git a/src/process-unix.c b/src/process-unix.c index 8220dcc..a62b7f9 100644 --- a/src/process-unix.c +++ b/src/process-unix.c @@ -1,4 +1,4 @@ -/* Asynchronous subprocess implemenation for UNIX +/* Asynchronous subprocess implementation for UNIX Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. @@ -37,11 +37,9 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "buffer.h" -#include "commands.h" #include "events.h" #include "frame.h" #include "hash.h" -#include "insdel.h" #include "lstream.h" #include "opaque.h" #include "process.h" @@ -62,7 +60,7 @@ Boston, MA 02111-1307, USA. */ /* - * Implemenation-specific data. Pointed to by Lisp_Process->process_data + * Implementation-specific data. Pointed to by Lisp_Process->process_data */ struct unix_process_data @@ -236,7 +234,7 @@ allocate_pty (void) #else /* no PTY_OPEN */ #ifdef IRIS /* Unusual IRIS code */ - *ptyv = open ("/dev/ptc", O_RDWR | O_NDELAY | OPEN_BINARY, 0); + *ptyv = open ("/dev/ptc", O_RDWR | O_NONBLOCK | OPEN_BINARY, 0); if (fd < 0) return -1; if (fstat (fd, &stb) < 0) @@ -250,11 +248,7 @@ allocate_pty (void) } else failed_count = 0; -#ifdef O_NONBLOCK fd = open (pty_name, O_RDWR | O_NONBLOCK | OPEN_BINARY, 0); -#else - fd = open (pty_name, O_RDWR | O_NDELAY | OPEN_BINARY, 0); -#endif #endif /* not IRIS */ #endif /* no PTY_OPEN */ @@ -672,11 +666,11 @@ static void unix_mark_process_data (struct Lisp_Process *proc, void (*markobj) (Lisp_Object)) { - ((markobj) (UNIX_DATA(proc)->tty_name)); + markobj (UNIX_DATA(proc)->tty_name); } /* - * Initialize XEmacs process implemenation once + * Initialize XEmacs process implementation once */ #ifdef SIGCHLD @@ -708,7 +702,7 @@ unix_init_process_io_handles (struct Lisp_Process *p, void* in, void* out, int f * object. If this function signals, the caller is responsible for * deleting (and finalizing) the process object. * - * The method must return PID of the new proces, a (positive??? ####) number + * The method must return PID of the new process, a (positive??? ####) number * which fits into Lisp_Int. No return value indicates an error, the method * must signal an error instead. */ @@ -802,14 +796,6 @@ unix_create_process (struct Lisp_Process *p, char **save_environ = environ; #endif -#ifdef EMACS_BTL - /* when performance monitoring is on, turn it off before the vfork(), - as the child has no handler for the signal -- when back in the - parent process, turn it back on if it was really on when you "turned - it off" */ - int logging_on = cadillac_stop_logging (); /* #### rename me */ -#endif - pid = fork (); if (pid == 0) { @@ -925,7 +911,7 @@ unix_create_process (struct Lisp_Process *p, will die when we want it to. JV: This needs to be done ALWAYS as we might have inherited a SIG_IGN handling from our parent (nohup) and we are in new - process group. + process group. */ signal (SIGHUP, SIG_DFL); } @@ -942,10 +928,6 @@ unix_create_process (struct Lisp_Process *p, child_setup (xforkin, xforkout, xforkout, new_argv, current_dir); } -#ifdef EMACS_BTL - else if (logging_on) - cadillac_start_logging (); /* #### rename me */ -#endif #if !defined(__CYGWIN32__) environ = save_environ; @@ -996,9 +978,7 @@ io_failure: RETURN_NOT_REACHED (0); } -/* - * Return nonzero if this process is a ToolTalk connection. - */ +/* Return nonzero if this process is a ToolTalk connection. */ static int unix_tooltalk_connection_p (struct Lisp_Process *p) @@ -1006,9 +986,7 @@ unix_tooltalk_connection_p (struct Lisp_Process *p) return UNIX_DATA(p)->connected_via_filedesc_p; } -/* - * This is called to set process' virtual terminal size - */ +/* This is called to set process' virtual terminal size */ static int unix_set_window_size (struct Lisp_Process* p, int cols, int rows) @@ -1132,7 +1110,7 @@ unix_reap_exited_processes (void) #endif /* SIGCHLD */ /* - * Stuff the entire contents of LSTREAM to the process ouptut pipe + * Stuff the entire contents of LSTREAM to the process output pipe */ static JMP_BUF send_process_frame; @@ -1180,8 +1158,7 @@ unix_send_process (Lisp_Object proc, struct lstream* lstream) if (writeret < 0) /* This is a real error. Blocking errors are handled specially inside of the filedesc stream. */ - report_file_error ("writing to process", - list1 (vol_proc)); + report_file_error ("writing to process", list1 (proc)); while (Lstream_was_blocked_p (XLSTREAM (p->pipe_outstream))) { /* Buffer is full. Wait, accepting input; @@ -1207,7 +1184,7 @@ unix_send_process (Lisp_Object proc, struct lstream* lstream) p->core_dumped = 0; p->tick++; process_tick++; - deactivate_process (vol_proc); + deactivate_process (*((Lisp_Object *) (&vol_proc))); error ("SIGPIPE raised on process %s; closed it", XSTRING_DATA (p->name)); } @@ -1254,7 +1231,7 @@ unix_process_send_eof (Lisp_Object proc) * In the lack of this method, only event_stream_delete_stream_pair * is called on both I/O streams of the process. * - * The UNIX version quards this by ignoring possible SIGPIPE. + * The UNIX version guards this by ignoring possible SIGPIPE. */ static USID @@ -1425,7 +1402,7 @@ unix_get_tty_name (struct Lisp_Process *p) /* * Canonicalize host name HOST, and return its canonical form * - * The default implemenation just takes HOST for a canonical name. + * The default implementation just takes HOST for a canonical name. */ #ifdef HAVE_SOCKETS @@ -1575,7 +1552,7 @@ unix_open_network_stream (Lisp_Object name, Lisp_Object host, Lisp_Object servic TCP case, the multicast connection will be seen as a sub-process, Some notes: - - Normaly, we should use sendto and recvfrom with non connected + - Normally, we should use sendto and recvfrom with non connected sockets. The current code doesn't allow us to do this. In the future, it would be a good idea to extend the process data structure in order to deal properly with the different types network connections. @@ -1656,7 +1633,7 @@ unix_open_multicast_group (Lisp_Object name, Lisp_Object dest, Lisp_Object port, /* Socket configuration for writing ----------------------- */ - /* Normaly, there's no 'connect' in multicast, since we use preferentialy + /* Normally, there's no 'connect' in multicast, since we prefer to use 'sendto' and 'recvfrom'. However, in order to handle this connection in the process-like way it is done for TCP, we must be able to use 'write' instead of 'sendto'. Consequently, we 'connect' this socket. */ diff --git a/src/process.c b/src/process.c index 578b0c3..a9a9131 100644 --- a/src/process.c +++ b/src/process.c @@ -46,7 +46,6 @@ Boston, MA 02111-1307, USA. */ #include "opaque.h" #include "process.h" #include "procimpl.h" -#include "sysdep.h" #include "window.h" #ifdef FILE_CODING #include "file-coding.h" @@ -100,9 +99,9 @@ static int update_tick; /* Nonzero means delete a process right away if it exits. */ int delete_exited_processes; -/* Hashtable which maps USIDs as returned by create_stream_pair_cb to +/* Hash table which maps USIDs as returned by create_stream_pair_cb to process objects. Processes are not GC-protected through this! */ -c_hashtable usid_to_process; +struct hash_table *usid_to_process; /* List of process objects. */ Lisp_Object Vprocess_list; @@ -114,18 +113,18 @@ mark_process (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Process *proc = XPROCESS (obj); MAYBE_PROCMETH (mark_process_data, (proc, markobj)); - ((markobj) (proc->name)); - ((markobj) (proc->command)); - ((markobj) (proc->filter)); - ((markobj) (proc->sentinel)); - ((markobj) (proc->buffer)); - ((markobj) (proc->mark)); - ((markobj) (proc->pid)); - ((markobj) (proc->pipe_instream)); - ((markobj) (proc->pipe_outstream)); + markobj (proc->name); + markobj (proc->command); + markobj (proc->filter); + markobj (proc->sentinel); + markobj (proc->buffer); + markobj (proc->mark); + markobj (proc->pid); + markobj (proc->pipe_instream); + markobj (proc->pipe_outstream); #ifdef FILE_CODING - ((markobj) (proc->coding_instream)); - ((markobj) (proc->coding_outstream)); + markobj (proc->coding_instream); + markobj (proc->coding_outstream); #endif return proc->status_symbol; } @@ -192,7 +191,7 @@ DEFINE_LRECORD_IMPLEMENTATION ("process", process, /************************************************************************/ /* Under FILE_CODING, this function returns low-level streams, connected - directrly to the child process, rather than en/decoding FILE_CODING + directly to the child process, rather than en/decoding FILE_CODING streams */ void get_process_streams (struct Lisp_Process *p, @@ -357,7 +356,7 @@ get_process (Lisp_Object name) else { /* #### This was commented out. Although, simple - (kill-process 7 "qqq") resulted in a falat error. - kkm */ + (kill-process 7 "qqq") resulted in a fatal error. - kkm */ CHECK_PROCESS (obj); proc = obj; } @@ -643,8 +642,8 @@ INCODE and OUTCODE specify the coding-system objects used in input/output functions must then go to lisp and provide a suitable list for the generalized connection function. - Both UNIX ans Win32 support BSD sockets, and there are many extensions - availalble (Sockets 2 spec). + Both UNIX and Win32 support BSD sockets, and there are many extensions + available (Sockets 2 spec). A todo is define a consistent set of properties abstracting a network connection. -kkm @@ -897,7 +896,7 @@ read_process_output (Lisp_Object proc) old_zv += nchars; #if 0 - /* This screws up intial display of the window. jla */ + /* This screws up initial display of the window. jla */ /* Insert before markers in case we are inserting where the buffer's mark is, and the user's next command is Meta-y. */ @@ -1743,7 +1742,7 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. handle_signal (SIGUNUSED); #endif #ifdef SIGDANGER - handle_signal (SIGDANGER); + handle_signal (SIGDANGER); /* AIX */ #endif #ifdef SIGMSG handle_signal (SIGMSG); @@ -1946,7 +1945,11 @@ init_xemacs_process (void) MAYBE_PROCMETH (init_process, ()); Vprocess_list = Qnil; - usid_to_process = make_hashtable (32); + + if (usid_to_process) + clrhash (usid_to_process); + else + usid_to_process = make_hash_table (32); } #if 0 @@ -2054,11 +2057,11 @@ The value takes effect when `start-process' is called. Vprocess_connection_type = Qt; DEFVAR_BOOL ("windowed-process-io", &windowed_process_io /* -Enables input/ouptut on standard handles of a windowed process. +Enables input/output on standard handles of a windowed process. When this variable is nil (the default), XEmacs does not attempt to read standard output handle of a windowed process. Instead, the process is immediately marked as exited immediately upon successful launching. This is -done because normal windowed processes do not use stadnard I/O, as they are +done because normal windowed processes do not use standard I/O, as they are not connected to any console. When launching a specially crafted windowed process, which expects to be diff --git a/src/procimpl.h b/src/procimpl.h index da4557d..b16c1e0 100644 --- a/src/procimpl.h +++ b/src/procimpl.h @@ -29,7 +29,7 @@ struct Lisp_Process; /* * Structure which keeps methods of the process implementation. - * There is only one object of this class exists in a perticular + * There is only one object of this class exists in a particular * XEmacs implementation. */ @@ -163,7 +163,7 @@ extern Lisp_Object Qtcpip; extern Lisp_Object Vprocess_connection_type; extern Lisp_Object Vprocess_list; -extern c_hashtable usid_to_process; +extern struct hash_table *usid_to_process; extern volatile int process_tick; diff --git a/src/profile.c b/src/profile.c index 80e89fb..6fa506b 100644 --- a/src/profile.c +++ b/src/profile.c @@ -24,6 +24,7 @@ Boston, MA 02111-1307, USA. */ #include "backtrace.h" #include "bytecode.h" +#include "elhash.h" #include "hash.h" #include "syssignal.h" @@ -38,25 +39,25 @@ Boston, MA 02111-1307, USA. */ (ITIMER_PROF), which generates a SIGPROF every so often. (This runs not in real time but rather when the process is executing or the system is running on behalf of the process.) When the signal - goes off, we see what we're in, and add by 1 the count associated + goes off, we see what we're in, and add 1 to the count associated with that function. It would be nice to use the Lisp allocation mechanism etc. to keep track of the profiling information, but we can't because that's not - safe, and trying to make it safe would be much more work than is + safe, and trying to make it safe would be much more work than it's worth. Jan 1998: In addition to this, I have added code to remember call counts of Lisp funcalls. The profile_increase_call_count() - function is called from funcall_recording_as(), and serves to add - data to Vcall_count_profile_table. This mechanism is much simpler - and independent of the SIGPROF-driven one. It uses the Lisp - allocation mechanism normally, since it is not called from a - handler. It may even be useful to provide a way to turn on only - one profiling mechanism, but I haven't done so yet. --hniksic */ - -c_hashtable big_profile_table; + function is called from Ffuncall(), and serves to add data to + Vcall_count_profile_table. This mechanism is much simpler and + independent of the SIGPROF-driven one. It uses the Lisp allocation + mechanism normally, since it is not called from a handler. It may + even be useful to provide a way to turn on only one profiling + mechanism, but I haven't done so yet. --hniksic */ + +struct hash_table *big_profile_table; Lisp_Object Vcall_count_profile_table; int default_profiling_interval; @@ -78,15 +79,16 @@ Lisp_Object QSunknown; enough to catch us while we're already in there. */ static volatile int inside_profiling; -/* Increase the value of OBJ in Vcall_count_profile_table hashtable. - If hashtable is nil, create it first. */ +/* Increase the value of OBJ in Vcall_count_profile_table hash table. + If the hash table is nil, create it first. */ void profile_increase_call_count (Lisp_Object obj) { Lisp_Object count; if (NILP (Vcall_count_profile_table)) - Vcall_count_profile_table = Fmake_hashtable (make_int (100), Qeq); + Vcall_count_profile_table = + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); count = Fgethash (obj, Vcall_count_profile_table, Qzero); if (!INTP (count)) @@ -117,8 +119,10 @@ sigprof_handler (int signo) { fun = *backtrace_list->function; - if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun)) - fun = QSunknown; + if (!GC_SYMBOLP (fun) && + !GC_COMPILED_FUNCTIONP (fun) && + !GC_SUBRP (fun)) + fun = QSunknown; } else fun = QSprocessing_events_at_top_level; @@ -163,12 +167,13 @@ will be properly accumulated. struct itimerval foo; /* #### The hash code can safely be called from a signal handler - except when it has to grow the hashtable. In this case, it calls - realloc(), which is not (in general) re-entrant. We just be + except when it has to grow the hash table. In this case, it calls + realloc(), which is not (in general) re-entrant. We'll just be sleazy and make the table large enough that it (hopefully) won't need to be realloc()ed. */ if (!big_profile_table) - big_profile_table = make_hashtable (10000); + big_profile_table = make_hash_table (10000); + if (NILP (microsecs)) msecs = default_profiling_interval; else @@ -301,7 +306,7 @@ Clear out the recorded profiling info. clrhash (big_profile_table); inside_profiling = 0; } - if (!NILP(Vcall_count_profile_table)) + if (!NILP (Vcall_count_profile_table)) Fclrhash (Vcall_count_profile_table); return Qnil; } @@ -328,7 +333,7 @@ void vars_of_profile (void) { DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /* -Default time in microseconds between profiling queries. +Default CPU time in microseconds between profiling sampling. Used when the argument to `start-profiling' is nil or omitted. Note that the time in question is CPU time (when the program is executing or the kernel is executing on behalf of the program) and not real time. @@ -337,8 +342,8 @@ or the kernel is executing on behalf of the program) and not real time. DEFVAR_LISP ("call-count-profile-table", &Vcall_count_profile_table /* The table where call-count information is stored by the profiling primitives. -This is a hashtable whose keys are funcallable objects, and whose - values are their call counts (integers). +This is a hash table whose keys are funcallable objects, and whose +values are their call counts (integers). */ ); Vcall_count_profile_table = Qnil; diff --git a/src/ralloc.c b/src/ralloc.c index 4c97bfc..5f336a9 100644 --- a/src/ralloc.c +++ b/src/ralloc.c @@ -1409,12 +1409,12 @@ static int r_alloc_initialized = 0; static int DEV_ZERO_FD = -1; -/* We actually need a datastructure that can be usefully structured +/* We actually need a data structure that can be usefully structured based on the VM address, and allows an ~O(1) lookup on an arbitrary - address, ie a hash-table. Maybe the XEmacs hash table can be - coaxed enough. At the moment, we use lookup on a hash-table to + address, i.e. a hash table. Maybe the XEmacs hash table can be + coaxed enough. At the moment, we use lookup on a hash table to decide whether to do an O(n) search on the malloced block list. - Addresses are hashed to a bucket modulo MHASH_PRIME */ + Addresses are hashed to a bucket modulo MHASH_PRIME. */ /* We settle for a standard doubly-linked-list. The dynarr type isn't diff --git a/src/rangetab.c b/src/rangetab.c index ee35b60..0edf541a4 100644 --- a/src/rangetab.c +++ b/src/rangetab.c @@ -47,7 +47,7 @@ mark_range_table (Lisp_Object obj, void (*markobj) (Lisp_Object)) int i; for (i = 0; i < Dynarr_length (rt->entries); i++) - (markobj) (Dynarr_at (rt->entries, i).val); + markobj (Dynarr_at (rt->entries, i).val); return Qnil; } @@ -242,15 +242,13 @@ If there is no corresponding value, return DEFAULT (defaults to nil). (pos, table, default_)) { struct Lisp_Range_Table *rt; - EMACS_INT po; CHECK_RANGE_TABLE (table); rt = XRANGE_TABLE (table); CHECK_INT_COERCE_CHAR (pos); - po = XINT (pos); - return get_range_table (po, Dynarr_length (rt->entries), + return get_range_table (XINT (pos), Dynarr_length (rt->entries), Dynarr_atp (rt->entries, 0), default_); } diff --git a/src/realpath.c b/src/realpath.c index 3af9c93..9f7489e 100644 --- a/src/realpath.c +++ b/src/realpath.c @@ -87,11 +87,11 @@ char resolved_path []; /* ** In NT we have two different cases: (1) the path name begins ** with a drive letter, e.g., "C:"; and (2) the path name begins - ** with just a slash, which roots to the current drive. In the + ** with just a slash, which roots to the current drive. In the ** first case we are going to leave things alone, in the second ** case we will prepend the drive letter to the given path. ** Note: So far in testing, I'm only seeing case #1, even though - ** I've tried to get the other cases to happen. + ** I've tried to get the other cases to happen. ** August Hill, 31 Aug 1997. ** ** Check for a driver letter...C:/... diff --git a/src/redisplay-msw.c b/src/redisplay-msw.c index 17394f4..8c77725 100644 --- a/src/redisplay-msw.c +++ b/src/redisplay-msw.c @@ -54,7 +54,7 @@ Boston, MA 02111-1307, USA. */ #define MSWINDOWS_EOL_CURSOR_WIDTH 5 /* - * Random forward delarations + * Random forward declarations */ static void mswindows_update_dc (HDC hdc, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, Lisp_Object bg_pmap); @@ -1087,7 +1087,7 @@ mswindows_ring_bell (struct device *d, int volume, int pitch, int duration) Given a display line, a block number for that start line, output all runes between start and end in the specified display block. - Ripped off with mininmal thought from the corresponding X routine. + Ripped off with minimal thought from the corresponding X routine. ****************************************************************************/ static void mswindows_output_display_block (struct window *w, struct display_line *dl, int block, @@ -1346,7 +1346,7 @@ mswindows_output_vertical_divider (struct window *w, int clear_unused) /* Draw a shadow around the divider */ if (shadow != 0) { - /* #### This will be fixed to support arbitrary thichkness */ + /* #### This will be fixed to support arbitrary thickness */ InflateRect (&rect, abs_shadow, abs_shadow); DrawEdge (FRAME_MSWINDOWS_DC (f), &rect, shadow > 0 ? EDGE_RAISED : EDGE_SUNKEN, BF_RECT); diff --git a/src/redisplay-output.c b/src/redisplay-output.c index 6266fd5..612334e 100644 --- a/src/redisplay-output.c +++ b/src/redisplay-output.c @@ -28,7 +28,6 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" -#include "debug.h" #include "buffer.h" #include "window.h" @@ -38,8 +37,6 @@ Boston, MA 02111-1307, USA. */ #include "redisplay.h" #include "faces.h" -#include "sysdep.h" - static int compare_runes (struct window *w, struct rune *crb, struct rune *drb); static void redraw_cursor_in_window (struct window *w, @@ -538,7 +535,7 @@ output_display_line (struct window *w, display_line_dynarr *cdla, a TEXT block. */ if (ddl->modeline) { - /* The shadow thickness check is necesssary if only the sign of + /* The shadow thickness check is necessary if only the sign of the size changed. */ if (cdba && !w->shadow_thickness_changed) { diff --git a/src/redisplay-tty.c b/src/redisplay-tty.c index 9e8515d..4576b45 100644 --- a/src/redisplay-tty.c +++ b/src/redisplay-tty.c @@ -289,7 +289,7 @@ tty_output_display_block (struct window *w, struct display_line *dl, int block, elt++; } } - /* #### RUNE_HLINE is actualy a little more complicated than this + /* #### RUNE_HLINE is actually a little more complicated than this but at the moment it is only used to draw a turned off modeline and this will suffice for that. */ else if (rb->type == RUNE_BLANK || rb->type == RUNE_HLINE) diff --git a/src/redisplay-x.c b/src/redisplay-x.c index 16bb75a..39b4c1d 100644 --- a/src/redisplay-x.c +++ b/src/redisplay-x.c @@ -929,7 +929,7 @@ x_output_string (struct window *w, struct display_line *dl, { /* Ensure the gray bitmap exists */ if (DEVICE_X_GRAY_PIXMAP (d) == None) - DEVICE_X_GRAY_PIXMAP (d) = + DEVICE_X_GRAY_PIXMAP (d) = XCreateBitmapFromData (dpy, x_win, (char *)gray_bits, gray_width, gray_height); @@ -1410,7 +1410,7 @@ x_output_vertical_divider (struct window *w, int clear) unsigned long mask; int x, y1, y2, width, shadow_thickness, spacing, line_width; face_index div_face = get_builtin_face_cache_index (w, Vvertical_divider_face); - + width = window_divider_width (w); shadow_thickness = XINT (w->vertical_divider_shadow_thickness); spacing = XINT (w->vertical_divider_spacing); @@ -1418,20 +1418,20 @@ x_output_vertical_divider (struct window *w, int clear) x = WINDOW_RIGHT (w) - width; y1 = WINDOW_TOP (w); y2 = WINDOW_BOTTOM (w); - + memset (&gcv, ~0, sizeof (XGCValues)); - + tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); - + /* First, get the GC's. */ top_shadow_pixel = tmp_color.pixel; bottom_shadow_pixel = tmp_color.pixel; background_pixel = tmp_color.pixel; - + x_generate_shadow_pixels (f, &top_shadow_pixel, &bottom_shadow_pixel, background_pixel, ef->core.background_pixel); - + tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); gcv.background = tmp_color.pixel; @@ -1439,11 +1439,11 @@ x_output_vertical_divider (struct window *w, int clear) mask = GCForeground | GCBackground | GCGraphicsExposures; /* If we can't distinguish one of the shadows (the color is the same as the - background), it's better to use a pixmap to generate a dithrered gray. */ + background), it's better to use a pixmap to generate a dithered gray. */ if (top_shadow_pixel == background_pixel || bottom_shadow_pixel == background_pixel) use_pixmap = 1; - + if (use_pixmap) { if (DEVICE_X_GRAY_PIXMAP (d) == None) @@ -1452,7 +1452,7 @@ x_output_vertical_divider (struct window *w, int clear) XCreatePixmapFromBitmapData (dpy, x_win, (char *) gray_bits, gray_width, gray_height, 1, 0, 1); } - + tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); gcv.foreground = tmp_color.pixel; @@ -1461,11 +1461,11 @@ x_output_vertical_divider (struct window *w, int clear) gcv.stipple = DEVICE_X_GRAY_PIXMAP (d); top_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, (mask | GCStipple | GCFillStyle)); - + tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); bottom_shadow_pixel = tmp_color.pixel; - + flip_gcs = (bottom_shadow_pixel == WhitePixelOfScreen (DefaultScreenOfDisplay (dpy))); } @@ -1474,20 +1474,20 @@ x_output_vertical_divider (struct window *w, int clear) gcv.foreground = top_shadow_pixel; top_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask); } - + gcv.foreground = bottom_shadow_pixel; bottom_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask); - + if (use_pixmap && flip_gcs) { GC tmp_gc = bottom_shadow_gc; bottom_shadow_gc = top_shadow_gc; top_shadow_gc = tmp_gc; } - + gcv.foreground = background_pixel; background_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask); - + /* possibly revert the GC's in case the shadow thickness is < 0. This will give a depressed look to the divider */ if (shadow_thickness < 0) @@ -1497,8 +1497,8 @@ x_output_vertical_divider (struct window *w, int clear) temp = top_shadow_gc; top_shadow_gc = bottom_shadow_gc; bottom_shadow_gc = temp; - - /* better avoid a Bad Adress XLib error ;-) */ + + /* better avoid a Bad Address XLib error ;-) */ shadow_thickness = - shadow_thickness; } @@ -1508,12 +1508,12 @@ x_output_vertical_divider (struct window *w, int clear) XClearArea (dpy, x_win, x, y1, width, y2 - y1, False); /* Draw the divider line. */ - XFillRectangle (dpy, x_win, background_gc, + XFillRectangle (dpy, x_win, background_gc, x + spacing + shadow_thickness, y1, line_width, y2 - y1); - + /* Draw the shadows around the divider line */ - x_output_shadows (f, x + spacing, y1, + x_output_shadows (f, x + spacing, y1, width - 2 * spacing, y2 - y1, top_shadow_gc, bottom_shadow_gc, background_gc, shadow_thickness); @@ -1678,7 +1678,7 @@ x_output_hline (struct window *w, struct display_line *dl, struct rune *rb) x_output_shadows Draw a shadow around the given area using the given GC's. It is the - callers responsibility to ste the GC's appropriately. + callers responsibility to set the GC's appropriately. ****************************************************************************/ void x_output_shadows (struct frame *f, int x, int y, int width, int height, diff --git a/src/redisplay.c b/src/redisplay.c index 9ae8b46..af19d9b 100644 --- a/src/redisplay.c +++ b/src/redisplay.c @@ -46,6 +46,7 @@ Boston, MA 02111-1307, USA. */ #include "commands.h" #include "debug.h" #include "device.h" +#include "elhash.h" #include "extents.h" #include "faces.h" #include "frame.h" @@ -1805,7 +1806,7 @@ create_text_block (struct window *w, struct display_line *dl, like: a) A 256-entry vector, for backward compatibility - b) Some sort of hashtable, mapping characters to values + b) Some sort of hash table, mapping characters to values c) A list that specifies a range of values and the mapping to provide for those values. @@ -2338,7 +2339,7 @@ done: { /* If data.start_col_enabled is still true, then the window is scrolled far enough so that nothing on this line is visible. - We need to stick a trunctation glyph at the beginning of the + We need to stick a truncation glyph at the beginning of the line in that case unless the line is completely blank. */ if (data.bi_start_col_enabled) { @@ -2871,7 +2872,7 @@ create_left_glyph_block (struct window *w, struct display_line *dl, they should start. The inside margin glyphs get whatever space is left after the whitespace glyphs have been displayed. These are tricky to calculate since if we decide to use the overflow - area we basicaly have to start over. So for these we build up a + area we basically have to start over. So for these we build up a list of just the inside margin glyphs and manipulate it to determine the needed info. */ { @@ -3000,7 +3001,7 @@ create_left_glyph_block (struct window *w, struct display_line *dl, struct glyph_block *gb = Dynarr_atp (dl->left_glyphs, elt); if (NILP (gb->extent)) - abort (); /* these should have beeb handled in add_glyph_rune */ + abort (); /* these should have been handled in add_glyph_rune */ if (extent_begin_glyph_layout (XEXTENT (gb->extent)) == GL_OUTSIDE_MARGIN) @@ -3190,7 +3191,7 @@ create_right_glyph_block (struct window *w, struct display_line *dl) they should start. The inside margin glyphs get whatever space is left after the whitespace glyphs have been displayed. These are tricky to calculate since if we decide to use the overflow - area we basicaly have to start over. So for these we build up a + area we basically have to start over. So for these we build up a list of just the inside margin glyphs and manipulate it to determine the needed info. */ { @@ -3313,7 +3314,7 @@ create_right_glyph_block (struct window *w, struct display_line *dl) struct glyph_block *gb = Dynarr_atp (dl->right_glyphs, elt); if (NILP (gb->extent)) - abort (); /* these should have beeb handled in add_glyph_rune */ + abort (); /* these should have been handled in add_glyph_rune */ if (extent_end_glyph_layout (XEXTENT (gb->extent)) == GL_OUTSIDE_MARGIN) { @@ -3524,7 +3525,7 @@ generate_modeline (struct window *w, struct display_line *dl, int type) MODELINE_INDEX, min_pixpos, max_pixpos, type); /* The modeline is at the bottom of the gutters. We have to wait to - set this until we've generated teh modeline in order to account + set this until we've generated the modeline in order to account for any embedded faces. */ dl->ypos = WINDOW_BOTTOM (w) - dl->descent - ypos_adj; } @@ -5049,7 +5050,7 @@ redisplay_window (Lisp_Object window, int skip_selected) Fset_marker (w->pointm[DESIRED_DISP], make_int (pointm), the_buffer); - /* #### BUFU amounts of overkil just to get the cursor + /* #### BUFU amounts of overkill just to get the cursor location marked properly. FIX ME FIX ME FIX ME */ regenerate_window (w, startp, pointm, DESIRED_DISP); } @@ -5241,7 +5242,7 @@ regeneration_done: redisplay_output_window (w); /* * If we just displayed the echo area, the line start cache is - * no longer valid, because the minibuffer window is assocaited + * no longer valid, because the minibuffer window is associated * with the window now. */ if (echo_active) @@ -5354,13 +5355,13 @@ redisplay_frame (struct frame *f, int preemption_check) change_frame_size (f, f->new_height, f->new_width, 0); /* If frame size might need to be changed, due to changed size - of toolbars, scroolabrs etc, change it now */ + of toolbars, scrollbars etc, change it now */ if (f->size_slipped) { adjust_frame_size (f); assert (!f->size_slipped); } - + /* The menubar, toolbar, and icon updates must be done before hold_frame_size_changes is called and we are officially 'in_display'. They may eval lisp code which may call Fsignal. @@ -5703,9 +5704,9 @@ window_line_number (struct window *w, int type) { struct device *d = XDEVICE (XFRAME (w->frame)->device); struct buffer *b = XBUFFER (w->buffer); - /* Be careful in the order of these tests. The first clasue will + /* Be careful in the order of these tests. The first clause will fail if DEVICE_SELECTED_FRAME == Qnil (since w->frame cannot be). - This can occur when the frame title is computed really early */ + This can occur when the frame title is computed really early */ Bufpos pos = ((EQ(DEVICE_SELECTED_FRAME(d), w->frame) && (w == XWINDOW (FRAME_SELECTED_WINDOW (device_selected_frame(d)))) && @@ -6089,8 +6090,10 @@ mark_glyph_block_dynarr (glyph_block_dynarr *gba, void (*markobj) (Lisp_Object)) for (; gb < gb_last; gb++) { - if (!NILP (gb->glyph)) ((markobj) (gb->glyph)); - if (!NILP (gb->extent)) ((markobj) (gb->extent)); + if (!NILP (gb->glyph)) + markobj (gb->glyph); + if (!NILP (gb->extent)) + markobj (gb->extent); } } } @@ -6118,9 +6121,9 @@ mark_redisplay_structs (display_line_dynarr *dla, void (*markobj) (Lisp_Object)) if (r->type == RUNE_DGLYPH) { if (!NILP (r->object.dglyph.glyph)) - ((markobj) (r->object.dglyph.glyph)); + markobj (r->object.dglyph.glyph); if (!NILP (r->object.dglyph.extent)) - ((markobj) (r->object.dglyph.extent)); + markobj (r->object.dglyph.extent); } } } @@ -6264,7 +6267,7 @@ validate_line_start_cache (struct window *w) size changes can cause text shifting. However, the extent covering the region is constantly having its face set and priority altered by the mouse code. This means that the line - start cache is constanty being invalidated. This is bad + start cache is constantly being invalidated. This is bad since the mouse code also triggers heavy usage of the cache. Since it is an unlikely that f->extents being changed indicates that the cache really needs to be updated and if it @@ -7064,7 +7067,7 @@ update_line_start_cache (struct window *w, Bufpos from, Bufpos to, /* * Handle invisible text properly: - * If the last line we're inserting has the same end as the + * If the last line we're inserting has the same end as the * line before which it will be added, merge the two lines. */ if (Dynarr_length (cache) && @@ -7300,7 +7303,7 @@ get_position_object (struct display_line *dl, Lisp_Object *obj1, d->pixel_to_glyph_cache.obj1 = *obj1; \ d->pixel_to_glyph_cache.obj2 = *obj2; \ d->pixel_to_glyph_cache.retval = position; \ - RETURN__ position; \ + RETURN_SANS_WARNINGS position; \ } while (0) /* Given x and y coordinates in pixels relative to a frame, return @@ -8059,40 +8062,29 @@ redisplay_glyph_changed (Lisp_Object glyph, Lisp_Object property, { if (WINDOWP (locale)) { - struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (locale))); - MARK_FRAME_GLYPHS_CHANGED (f); + MARK_FRAME_GLYPHS_CHANGED (XFRAME (WINDOW_FRAME (XWINDOW (locale)))); } else if (FRAMEP (locale)) { - struct frame *f = XFRAME (locale); - MARK_FRAME_GLYPHS_CHANGED (f); + MARK_FRAME_GLYPHS_CHANGED (XFRAME (locale)); } else if (DEVICEP (locale)) { Lisp_Object frmcons; DEVICE_FRAME_LOOP (frmcons, XDEVICE (locale)) - { - struct frame *f = XFRAME (XCAR (frmcons)); - MARK_FRAME_GLYPHS_CHANGED (f); - } + MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons))); } else if (CONSOLEP (locale)) { Lisp_Object frmcons, devcons; CONSOLE_FRAME_LOOP_NO_BREAK (frmcons, devcons, XCONSOLE (locale)) - { - struct frame *f = XFRAME (XCAR (frmcons)); - MARK_FRAME_GLYPHS_CHANGED (f); - } + MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons))); } else /* global or buffer */ { Lisp_Object frmcons, devcons, concons; FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) - { - struct frame *f = XFRAME (XCAR (frmcons)); - MARK_FRAME_GLYPHS_CHANGED (f); - } + MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons))); } } @@ -8302,7 +8294,7 @@ line start cache. Minimum pixel height for clipped bottom display line. A clipped line shorter than this won't be displayed. */ , - redisplay_variable_changed); + redisplay_variable_changed); vertical_clip = 5; DEFVAR_INT_MAGIC ("pixel-horizontal-clip-threshold", &horizontal_clip /* @@ -8310,7 +8302,7 @@ Minimum visible area for clipped glyphs at right boundary. Clipped glyphs shorter than this won't be displayed. Only pixmap glyph instances are currently allowed to be clipped. */ , - redisplay_variable_changed); + redisplay_variable_changed); horizontal_clip = 5; DEFVAR_LISP ("global-mode-string", &Vglobal_mode_string /* @@ -8322,13 +8314,14 @@ String displayed by modeline-format's "%m" specification. Marker for where to display an arrow on top of the buffer text. This must be the beginning of a line in order to work. See also `overlay-arrow-string'. -*/ , redisplay_variable_changed); +*/ , + redisplay_variable_changed); Voverlay_arrow_position = Qnil; DEFVAR_LISP_MAGIC ("overlay-arrow-string", &Voverlay_arrow_string /* String to display as an arrow. See also `overlay-arrow-position'. */ , - redisplay_variable_changed); + redisplay_variable_changed); Voverlay_arrow_string = Qnil; DEFVAR_INT ("scroll-step", &scroll_step /* @@ -8347,7 +8340,7 @@ If this is zero, point is always centered after it moves off screen. &truncate_partial_width_windows /* *Non-nil means truncate lines in all windows less than full frame wide. */ , - redisplay_variable_changed); + redisplay_variable_changed); truncate_partial_width_windows = 1; DEFVAR_BOOL ("visible-bell", &visible_bell /* diff --git a/src/redisplay.h b/src/redisplay.h index 0d609bc..9059d4c 100644 --- a/src/redisplay.h +++ b/src/redisplay.h @@ -139,7 +139,7 @@ struct rune /* CHAR */ struct { - Emchar ch; /* Cbaracter of this rune. */ + Emchar ch; /* Character of this rune. */ } chr; /* HLINE */ @@ -256,7 +256,7 @@ struct display_line int cursor_elt; /* rune block of TEXT display block cursor is at or -1 */ char used_prop_data; /* can't incrementally update if line - used propogation data */ + used propagation data */ layout_bounds bounds; /* line boundary positions */ @@ -389,23 +389,23 @@ extern int windows_structure_changed; if each has already been called and don't bother doing most of the work if it is currently set. */ -#define MARK_TYPE_CHANGED(object) do { \ - if (!object##_changed_set) { \ - Lisp_Object _devcons_, _concons_; \ - DEVICE_LOOP_NO_BREAK (_devcons_, _concons_) \ - { \ - Lisp_Object _frmcons_; \ - struct device *_d_ = XDEVICE (XCAR (_devcons_)); \ - DEVICE_FRAME_LOOP (_frmcons_, _d_) \ - { \ - struct frame *_f_ = XFRAME (XCAR (_frmcons_)); \ - _f_->object##_changed = 1; \ - _f_->modiff++; \ - } \ - _d_->object##_changed = 1; \ - } \ - object##_changed = 1; \ - object##_changed_set = 1; } \ +#define MARK_TYPE_CHANGED(object) do { \ + if (!object##_changed_set) { \ + Lisp_Object MTC_devcons, MTC_concons; \ + DEVICE_LOOP_NO_BREAK (MTC_devcons, MTC_concons) \ + { \ + Lisp_Object MTC_frmcons; \ + struct device *MTC_d = XDEVICE (XCAR (MTC_devcons)); \ + DEVICE_FRAME_LOOP (MTC_frmcons, MTC_d) \ + { \ + struct frame *MTC_f = XFRAME (XCAR (MTC_frmcons)); \ + MTC_f->object##_changed = 1; \ + MTC_f->modiff++; \ + } \ + MTC_d->object##_changed = 1; \ + } \ + object##_changed = 1; \ + object##_changed_set = 1; } \ } while (0) #define MARK_BUFFERS_CHANGED MARK_TYPE_CHANGED (buffers) @@ -420,17 +420,17 @@ extern int windows_structure_changed; /* Anytime a console, device or frame is added or deleted we need to reset these flags. */ -#define RESET_CHANGED_SET_FLAGS \ - do { \ - buffers_changed_set = 0; \ - clip_changed_set = 0; \ - extents_changed_set = 0; \ - icon_changed_set = 0; \ - menubar_changed_set = 0; \ - modeline_changed_set = 0; \ - point_changed_set = 0; \ - toolbar_changed_set = 0; \ - glyphs_changed_set = 0; \ +#define RESET_CHANGED_SET_FLAGS \ + do { \ + buffers_changed_set = 0; \ + clip_changed_set = 0; \ + extents_changed_set = 0; \ + icon_changed_set = 0; \ + menubar_changed_set = 0; \ + modeline_changed_set = 0; \ + point_changed_set = 0; \ + toolbar_changed_set = 0; \ + glyphs_changed_set = 0; \ } while (0) @@ -438,7 +438,7 @@ extern int windows_structure_changed; /* redisplay global variables */ /*************************************************************************/ -/* redisplay structre used by various utility routines. */ +/* redisplay structure used by various utility routines. */ extern display_line_dynarr *cmotion_display_lines; /* Nonzero means truncate lines in all windows less wide than the frame. */ @@ -473,7 +473,7 @@ extern Lisp_Object Vglobal_mode_string; extern int display_arg; /* Type of display specified. Defined in emacs.c. */ -extern char *display_use; +extern CONST char *display_use; /* Nonzero means reading single-character input with prompt so put cursor on minibuffer after the prompt. */ diff --git a/src/regex.c b/src/regex.c index b8e9b25..d7618d1 100644 --- a/src/regex.c +++ b/src/regex.c @@ -1284,14 +1284,14 @@ typedef struct DEBUG_PRINT2 (" Pushing reg: %d\n", this_reg); \ DEBUG_STATEMENT (num_regs_pushed++); \ \ - DEBUG_PRINT2 (" start: 0x%p\n", regstart[this_reg]); \ + DEBUG_PRINT2 (" start: 0x%lx\n", (long) regstart[this_reg]); \ PUSH_FAILURE_POINTER (regstart[this_reg]); \ \ - DEBUG_PRINT2 (" end: 0x%p\n", regend[this_reg]); \ + DEBUG_PRINT2 (" end: 0x%lx\n", (long) regend[this_reg]); \ PUSH_FAILURE_POINTER (regend[this_reg]); \ \ DEBUG_PRINT2 (" info: 0x%lx\n ", \ - * (unsigned long *) (®_info[this_reg])); \ + * (long *) (®_info[this_reg])); \ DEBUG_PRINT2 (" match_null=%d", \ REG_MATCH_NULL_STRING_P (reg_info[this_reg])); \ DEBUG_PRINT2 (" active=%d", IS_ACTIVE (reg_info[this_reg])); \ @@ -1309,11 +1309,11 @@ typedef struct DEBUG_PRINT2 (" Pushing high active reg: %d\n", highest_active_reg);\ PUSH_FAILURE_INT (highest_active_reg); \ \ - DEBUG_PRINT2 (" Pushing pattern 0x%p: ", pattern_place); \ + DEBUG_PRINT2 (" Pushing pattern 0x%lx: ", (long) pattern_place); \ DEBUG_PRINT_COMPILED_PATTERN (bufp, pattern_place, pend); \ PUSH_FAILURE_POINTER (pattern_place); \ \ - DEBUG_PRINT2 (" Pushing string 0x%p: `", string_place); \ + DEBUG_PRINT2 (" Pushing string 0x%lx: `", (long) string_place); \ DEBUG_PRINT_DOUBLE_STRING (string_place, string1, size1, string2, \ size2); \ DEBUG_PRINT1 ("'\n"); \ @@ -1387,12 +1387,12 @@ typedef struct if (string_temp != NULL) \ str = (CONST char *) string_temp; \ \ - DEBUG_PRINT2 (" Popping string 0x%p: `", str); \ + DEBUG_PRINT2 (" Popping string 0x%lx: `", (long) str); \ DEBUG_PRINT_DOUBLE_STRING (str, string1, size1, string2, size2); \ DEBUG_PRINT1 ("'\n"); \ \ pat = (unsigned char *) POP_FAILURE_POINTER (); \ - DEBUG_PRINT2 (" Popping pattern 0x%p: ", pat); \ + DEBUG_PRINT2 (" Popping pattern 0x%lx: ", (long) pat); \ DEBUG_PRINT_COMPILED_PATTERN (bufp, pat, pend); \ \ /* Restore register info. */ \ @@ -1408,13 +1408,13 @@ typedef struct \ reg_info[this_reg].word = POP_FAILURE_ELT (); \ DEBUG_PRINT2 (" info: 0x%lx\n", \ - * (unsigned long *) ®_info[this_reg]); \ + * (long *) ®_info[this_reg]); \ \ regend[this_reg] = (CONST char *) POP_FAILURE_POINTER (); \ - DEBUG_PRINT2 (" end: 0x%p\n", regend[this_reg]); \ + DEBUG_PRINT2 (" end: 0x%lx\n", (long) regend[this_reg]); \ \ regstart[this_reg] = (CONST char *) POP_FAILURE_POINTER (); \ - DEBUG_PRINT2 (" start: 0x%p\n", regstart[this_reg]); \ + DEBUG_PRINT2 (" start: 0x%lx\n", (long) regstart[this_reg]); \ } \ \ set_regs_matched_done = 0; \ @@ -3315,7 +3315,7 @@ compile_extended_range (CONST char **p_ptr, CONST char *pend, char *translate, return syntax & RE_NO_EMPTY_RANGES ? REG_ERANGE : REG_NOERROR; /* Can't have ranges spanning different charsets, except maybe for - ranges entirely witin the first 256 chars. */ + ranges entirely within the first 256 chars. */ if ((range_start >= 0x100 || range_end >= 0x100) && CHAR_LEADING_BYTE (range_start) != @@ -4473,7 +4473,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, CONST char *string1, fails at this starting point in the input data. */ for (;;) { - DEBUG_PRINT2 ("\n0x%p: ", p); + DEBUG_PRINT2 ("\n0x%lx: ", (long) p); #ifdef emacs /* XEmacs added, w/removal of immediate_quit */ if (!no_quit_in_re_search) QUIT; @@ -5084,7 +5084,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, CONST char *string1, DEBUG_PRINT1 ("EXECUTING on_failure_keep_string_jump"); EXTRACT_NUMBER_AND_INCR (mcnt, p); - DEBUG_PRINT3 (" %d (to 0x%p):\n", mcnt, p + mcnt); + DEBUG_PRINT3 (" %d (to 0x%lx):\n", mcnt, (long) (p + mcnt)); PUSH_FAILURE_POINT (p + mcnt, (char *) 0, -2); break; @@ -5107,7 +5107,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, CONST char *string1, DEBUG_PRINT1 ("EXECUTING on_failure_jump"); EXTRACT_NUMBER_AND_INCR (mcnt, p); - DEBUG_PRINT3 (" %d (to 0x%p)", mcnt, p + mcnt); + DEBUG_PRINT3 (" %d (to 0x%lx)", mcnt, (long) (p + mcnt)); /* If this on_failure_jump comes right before a group (i.e., the original * applied to a group), save the information @@ -5322,7 +5322,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, CONST char *string1, EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */ DEBUG_PRINT2 ("EXECUTING jump %d ", mcnt); p += mcnt; /* Do the jump. */ - DEBUG_PRINT2 ("(to 0x%p).\n", p); + DEBUG_PRINT2 ("(to 0x%lx).\n", (long) p); break; @@ -5371,11 +5371,12 @@ re_match_2_internal (struct re_pattern_buffer *bufp, CONST char *string1, mcnt--; p += 2; STORE_NUMBER_AND_INCR (p, mcnt); - DEBUG_PRINT3 (" Setting 0x%p to %d.\n", p, mcnt); + DEBUG_PRINT3 (" Setting 0x%lx to %d.\n", (long) p, mcnt); } else if (mcnt == 0) { - DEBUG_PRINT2 (" Setting two bytes from 0x%p to no_op.\n", p+2); + DEBUG_PRINT2 (" Setting two bytes from 0x%lx to no_op.\n", + (long) (p+2)); p[2] = (unsigned char) no_op; p[3] = (unsigned char) no_op; goto on_failure; @@ -5405,7 +5406,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, CONST char *string1, EXTRACT_NUMBER_AND_INCR (mcnt, p); p1 = p + mcnt; EXTRACT_NUMBER_AND_INCR (mcnt, p); - DEBUG_PRINT3 (" Setting 0x%p to %d.\n", p1, mcnt); + DEBUG_PRINT3 (" Setting 0x%lx to %d.\n", (long) p1, mcnt); STORE_NUMBER (p1, mcnt); break; } diff --git a/src/s/freebsd.h b/src/s/freebsd.h index 32eec34..7a11597 100644 --- a/src/s/freebsd.h +++ b/src/s/freebsd.h @@ -55,7 +55,7 @@ #endif #define LD_SWITCH_SYSTEM #define START_FILES pre-crt0.o /usr/lib/crt1.o /usr/lib/crti.o /usr/lib/crtbegin.o -#define UNEXEC unexelf.o +#define UNEXEC "unexelf.o" #define LIB_STANDARD -lgcc -lc -lgcc /usr/lib/crtend.o /usr/lib/crtn.o #define LINKER "$(CC) -nostdlib" #undef LIB_GCC diff --git a/src/s/linux.h b/src/s/linux.h index 55f1f42..906bab4 100644 --- a/src/s/linux.h +++ b/src/s/linux.h @@ -131,6 +131,13 @@ Boston, MA 02111-1307, USA. */ /* mrb - Ordinary link is simple and effective */ /* slb - Not any more ... :-( */ #define ORDINARY_LINK +#endif /* 0 */ + +/* I still think ORDINARY_LINK should be the default, but since slb + insists, ORDINARY_LINK will stay on until we expunge the dump code. + However, the user (i.e. me!) should be able to specify ORDINARY_LINK via + configure --cppflags=-DORDINARY_LINK ... */ +#ifdef ORDINARY_LINK #undef LIB_STANDARD #undef START_FILES #undef LIB_GCC diff --git a/src/scrollbar-msw.c b/src/scrollbar-msw.c index 0e0526b..20eeb9c 100644 --- a/src/scrollbar-msw.c +++ b/src/scrollbar-msw.c @@ -1,6 +1,6 @@ /* scrollbar implementation -- mswindows interface. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. - Copyright (C) 1994 Amdhal Corporation. + Copyright (C) 1994 Amdahl Corporation. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred . diff --git a/src/scrollbar-x.c b/src/scrollbar-x.c index 01dea88..e35084e 100644 --- a/src/scrollbar-x.c +++ b/src/scrollbar-x.c @@ -1,6 +1,6 @@ /* scrollbar implementation -- X interface. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. - Copyright (C) 1994 Amdhal Corporation. + Copyright (C) 1994 Amdahl Corporation. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred . @@ -28,8 +28,6 @@ Boston, MA 02111-1307, USA. */ #include "console-x.h" #include "glyphs-x.h" -#include "EmacsFrame.h" -#include "EmacsManager.h" #include "gui-x.h" #include "scrollbar-x.h" diff --git a/src/scrollbar.c b/src/scrollbar.c index 22a7228..7717903 100644 --- a/src/scrollbar.c +++ b/src/scrollbar.c @@ -95,10 +95,10 @@ free_scrollbar_instance (struct scrollbar_instance *instance, static void free_window_mirror_scrollbars (struct window_mirror *mir) { - struct frame *f = mir->frame; - free_scrollbar_instance (mir->scrollbar_vertical_instance, f); + free_scrollbar_instance (mir->scrollbar_vertical_instance, mir->frame); mir->scrollbar_vertical_instance = 0; - free_scrollbar_instance (mir->scrollbar_horizontal_instance, f); + + free_scrollbar_instance (mir->scrollbar_horizontal_instance, mir->frame); mir->scrollbar_horizontal_instance = 0; } @@ -109,12 +109,7 @@ free_scrollbars_loop (Lisp_Object window, struct window_mirror *mir) while (mir) { - struct scrollbar_instance *vinst = mir->scrollbar_vertical_instance; - struct scrollbar_instance *hinst = mir->scrollbar_horizontal_instance; - struct frame *f; - assert (!NILP (window)); - f = XFRAME (XWINDOW (window)->frame); if (mir->vchild) { @@ -130,7 +125,8 @@ free_scrollbars_loop (Lisp_Object window, struct window_mirror *mir) if (retval != NULL) return retval; - if (hinst || vinst) + if (mir->scrollbar_vertical_instance || + mir->scrollbar_horizontal_instance) free_window_mirror_scrollbars (mir); mir = mir->next; @@ -141,19 +137,7 @@ free_scrollbars_loop (Lisp_Object window, struct window_mirror *mir) } /* Destroy all scrollbars associated with FRAME. Only called from - delete_frame_internal. - */ -#define FREE_FRAME_SCROLLBARS_INTERNAL(cache) \ - do { \ - while (FRAME_SB_##cache (f)) \ - { \ - struct scrollbar_instance *tofree = FRAME_SB_##cache (f); \ - FRAME_SB_##cache (f) = FRAME_SB_##cache (f)->next; \ - tofree->next = NULL; \ - free_scrollbar_instance (tofree, f); \ - } \ - } while (0) - + delete_frame_internal. */ void free_frame_scrollbars (struct frame *f) { @@ -165,10 +149,22 @@ free_frame_scrollbars (struct frame *f) free_scrollbars_loop (f->root_window, f->root_mirror); - FREE_FRAME_SCROLLBARS_INTERNAL (VCACHE); - FREE_FRAME_SCROLLBARS_INTERNAL (HCACHE); + while (FRAME_SB_VCACHE (f)) + { + struct scrollbar_instance *tofree = FRAME_SB_VCACHE (f); + FRAME_SB_VCACHE (f) = FRAME_SB_VCACHE (f)->next; + tofree->next = NULL; + free_scrollbar_instance (tofree, f); + } + + while (FRAME_SB_HCACHE (f)) + { + struct scrollbar_instance *tofree = FRAME_SB_HCACHE (f); + FRAME_SB_HCACHE (f) = FRAME_SB_HCACHE (f)->next; + tofree->next = NULL; + free_scrollbar_instance (tofree, f); + } } -#undef FREE_FRAME_SCROLLBARS_INTERNAL static struct scrollbar_instance * @@ -354,13 +350,6 @@ release_window_mirror_scrollbars (struct window_mirror *mir) mir->scrollbar_horizontal_instance = 0; } -/* This check needs to be done in the device-specific side. */ -#define UPDATE_DATA_FIELD(field, value) \ - if (instance->field != value) {\ - instance->field = value;\ - instance->scrollbar_instance_changed = 1;\ - }\ - /* * If w->sb_point is on the top line then return w->sb_point else * return w->start. If flag, then return beginning point of line @@ -598,7 +587,7 @@ vertical_scrollbar_changed_in_window (Lisp_Object specifier, changing scrollbar affects only how the text and scrollbar are laid out in the window. If we do not want the dividers to show up always, then we mark more drastic change, because changing - divider appearane changes lotta things. Although we actually need + divider appearance changes lotta things. Although we actually need to do this only if the scrollbar has appeared or disappeared completely at either window edge, we do this always, as users usually do not reposition scrollbars 200 times a second or so. Do @@ -872,7 +861,7 @@ This ensures that VALUE is in the proper range for the horizontal scrollbar. /* Can't allow this out of set-window-hscroll's acceptable range. */ /* #### What hell on the earth this code limits scroll size to the - machine-dependant SHORT size? -- kkm */ + machine-dependent SHORT size? -- kkm */ if (hscroll < 0) hscroll = 0; else if (hscroll >= (1 << (SHORTBITS - 1)) - 1) @@ -1002,13 +991,13 @@ This is a specifier; use `set-specifier' to change it. frame_size_slipped); DEFVAR_SPECIFIER ("scrollbar-on-left-p", &Vscrollbar_on_left_p /* -*Whether the verical scrollbar is on the left side of window or frame. +*Whether the vertical scrollbar is on the left side of window or frame. This is a specifier; use `set-specifier' to change it. */ ); Vscrollbar_on_left_p = Fmake_specifier (Qboolean); { - /* Klugde. Under X, we want athena scrollbars on the left, + /* Kludge. Under X, we want athena scrollbars on the left, while all other scrollbars go on the right by default. */ Lisp_Object fallback = list1 (Fcons (Qnil, Qnil)); #if defined (HAVE_X_WINDOWS) \ @@ -1030,7 +1019,7 @@ This is a specifier; use `set-specifier' to change it. frame_size_slipped); DEFVAR_SPECIFIER ("scrollbar-on-top-p", &Vscrollbar_on_top_p /* -*Whether the verical scrollbar is on the top side of window or frame. +*Whether the horizontal scrollbar is on the top side of window or frame. This is a specifier; use `set-specifier' to change it. */ ); Vscrollbar_on_top_p = Fmake_specifier (Qboolean); diff --git a/src/search.c b/src/search.c index 82e27ca..cb66c4f 100644 --- a/src/search.c +++ b/src/search.c @@ -29,7 +29,6 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "buffer.h" -#include "commands.h" #include "insdel.h" #include "opaque.h" #ifdef REGION_CACHE_NEEDS_WORK @@ -684,31 +683,31 @@ scan_buffer (struct buffer *buf, Emchar target, Bufpos start, Bufpos end, } Bytind -bi_find_next_newline_no_quit (struct buffer *buf, Bytind from, int cnt) +bi_find_next_newline_no_quit (struct buffer *buf, Bytind from, int count) { - return bi_scan_buffer (buf, '\n', from, 0, cnt, 0, 0); + return bi_scan_buffer (buf, '\n', from, 0, count, 0, 0); } Bufpos -find_next_newline_no_quit (struct buffer *buf, Bufpos from, int cnt) +find_next_newline_no_quit (struct buffer *buf, Bufpos from, int count) { - return scan_buffer (buf, '\n', from, 0, cnt, 0, 0); + return scan_buffer (buf, '\n', from, 0, count, 0, 0); } Bufpos -find_next_newline (struct buffer *buf, Bufpos from, int cnt) +find_next_newline (struct buffer *buf, Bufpos from, int count) { - return scan_buffer (buf, '\n', from, 0, cnt, 0, 1); + return scan_buffer (buf, '\n', from, 0, count, 0, 1); } /* Like find_next_newline, but returns position before the newline, not after, and only search up to TO. This isn't just find_next_newline (...)-1, because you might hit TO. */ Bufpos -find_before_next_newline (struct buffer *buf, Bufpos from, Bufpos to, int cnt) +find_before_next_newline (struct buffer *buf, Bufpos from, Bufpos to, int count) { EMACS_INT shortage; - Bufpos pos = scan_buffer (buf, '\n', from, to, cnt, &shortage, 1); + Bufpos pos = scan_buffer (buf, '\n', from, to, count, &shortage, 1); if (shortage == 0) pos--; @@ -730,20 +729,21 @@ skip_chars (struct buffer *buf, int forwardp, int syntaxp, REGISTER int i; struct Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->mirror_syntax_table); - - CHECK_STRING (string); + Bufpos limit; if (NILP (lim)) - XSETINT (lim, forwardp ? BUF_ZV (buf) : BUF_BEGV (buf)); + limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf); else - CHECK_INT_COERCE_MARKER (lim); + { + CHECK_INT_COERCE_MARKER (lim); + limit = XINT (lim); - /* In any case, don't allow scan outside bounds of buffer. */ - if (XINT (lim) > BUF_ZV (buf)) - lim = make_int (BUF_ZV (buf)); - if (XINT (lim) < BUF_BEGV (buf)) - lim = make_int (BUF_BEGV (buf)); + /* In any case, don't allow scan outside bounds of buffer. */ + if (limit > BUF_ZV (buf)) limit = BUF_ZV (buf); + if (limit < BUF_BEGV (buf)) limit = BUF_BEGV (buf); + } + CHECK_STRING (string); p = XSTRING_DATA (string); pend = p + XSTRING_LENGTH (string); memset (fastmap, 0, sizeof (fastmap)); @@ -828,7 +828,7 @@ skip_chars (struct buffer *buf, int forwardp, int syntaxp, to worry about */ if (forwardp) { - while (BUF_PT (buf) < XINT (lim) + while (BUF_PT (buf) < limit && fastmap[(unsigned char) syntax_code_spec [(int) SYNTAX (syntax_table, @@ -838,7 +838,7 @@ skip_chars (struct buffer *buf, int forwardp, int syntaxp, } else { - while (BUF_PT (buf) > XINT (lim) + while (BUF_PT (buf) > limit && fastmap[(unsigned char) syntax_code_spec [(int) SYNTAX (syntax_table, @@ -851,7 +851,7 @@ skip_chars (struct buffer *buf, int forwardp, int syntaxp, { if (forwardp) { - while (BUF_PT (buf) < XINT (lim)) + while (BUF_PT (buf) < limit) { Emchar ch = BUF_FETCH_CHAR (buf, BUF_PT (buf)); if ((ch < 0400) ? fastmap[ch] : @@ -866,7 +866,7 @@ skip_chars (struct buffer *buf, int forwardp, int syntaxp, } else { - while (BUF_PT (buf) > XINT (lim)) + while (BUF_PT (buf) > limit) { Emchar ch = BUF_FETCH_CHAR (buf, BUF_PT (buf) - 1); if ((ch < 0400) ? fastmap[ch] : @@ -1383,7 +1383,7 @@ search_buffer (struct buffer *buf, Lisp_Object string, Bufpos bufpos, (EMACS_UINT) p_limit) cursor += BM_tab[*cursor]; } -/* If you are here, cursor is beyond the end of the searched region. */ + /* If you are here, cursor is beyond the end of the searched region. */ /* This can happen if you match on the far character of the pattern, */ /* because the "stride" of that character is infinity, a number able */ /* to throw you well beyond the end of the search. It can also */ @@ -1837,7 +1837,7 @@ and you do not need to specify it.) case_action = nochange; /* We tried an initialization */ /* but some C compilers blew it */ - if (search_regs.num_regs <= 0) + if (search_regs.num_regs == 0) error ("replace-match called before any match found"); if (NILP (string)) @@ -2219,7 +2219,7 @@ match_limit (Lisp_Object num, int beginningp) n = XINT (num); if (n < 0 || n >= search_regs.num_regs) args_out_of_range (num, make_int (search_regs.num_regs)); - if (search_regs.num_regs <= 0 || + if (search_regs.num_regs == 0 || search_regs.start[n] < 0) return Qnil; return make_int (beginningp ? search_regs.start[n] : search_regs.end[n]); @@ -2310,7 +2310,7 @@ to hold all the values, and if INTEGERS is non-nil, no consing is done. /* If REUSE is a list, store as many value elements as will fit into the elements of REUSE. */ - for (i = 0, tail = reuse; CONSP (tail); i++, tail = XCDR (tail)) + for (prev = Qnil, i = 0, tail = reuse; CONSP (tail); i++, tail = XCDR (tail)) { if (i < 2 * len + 2) XCAR (tail) = data[i]; diff --git a/src/signal.c b/src/signal.c index 11ede72..eadc6d3 100644 --- a/src/signal.c +++ b/src/signal.c @@ -355,7 +355,7 @@ Return non-nil if XEmacs is waiting for input from the user. This is intended for use by asynchronous timeout callbacks and by asynchronous process output filters and sentinels (not yet implemented in XEmacs). It will always be nil if XEmacs is not inside of -an asynchronout timeout or process callback. +an asynchronous timeout or process callback. */ ()) { diff --git a/src/sound.c b/src/sound.c index 9e000d4..fa52599 100644 --- a/src/sound.c +++ b/src/sound.c @@ -32,7 +32,6 @@ Boston, MA 02111-1307, USA. */ #include "console-x.h" #endif -#include "commands.h" #include "device.h" #include "redisplay.h" #include "sysdep.h" @@ -456,7 +455,7 @@ init_native_sound (struct device *d) else { /* We have to call gethostbyname() on the result of gethostname() - because the two aren't guarenteed to be the same name for the + because the two aren't guaranteed to be the same name for the same host: on some losing systems, one is a FQDN and the other is not. Here in the wide wonderful world of Unix it's rocket science to obtain the local hostname in a portable fashion. diff --git a/src/specifier.c b/src/specifier.c index 9d381d5..a0e5387 100644 --- a/src/specifier.c +++ b/src/specifier.c @@ -183,13 +183,13 @@ mark_specifier (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Specifier *specifier = XSPECIFIER (obj); - ((markobj) (specifier->global_specs)); - ((markobj) (specifier->device_specs)); - ((markobj) (specifier->frame_specs)); - ((markobj) (specifier->window_specs)); - ((markobj) (specifier->buffer_specs)); - ((markobj) (specifier->magic_parent)); - ((markobj) (specifier->fallback)); + markobj (specifier->global_specs); + markobj (specifier->device_specs); + markobj (specifier->frame_specs); + markobj (specifier->window_specs); + markobj (specifier->buffer_specs); + markobj (specifier->magic_parent); + markobj (specifier->fallback); if (!GHOST_SPECIFIER_P (XSPECIFIER (obj))) MAYBE_SPECMETH (specifier, mark, (obj, markobj)); return Qnil; @@ -223,14 +223,14 @@ prune_specifiers (int (*obj_marked_p) (Lisp_Object)) !GC_NILP (rest); rest = XSPECIFIER (rest)->next_specifier) { - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (rest)) { struct Lisp_Specifier* sp = XSPECIFIER (rest); /* A bit of assertion that we're removing both parts of the magic one altogether */ assert (!GC_MAGIC_SPECIFIER_P(sp) - || (GC_BODILY_SPECIFIER_P(sp) && (*obj_marked_p)(sp->fallback)) - || (GC_GHOST_SPECIFIER_P(sp) && (*obj_marked_p)(sp->magic_parent))); + || (GC_BODILY_SPECIFIER_P(sp) && obj_marked_p (sp->fallback)) + || (GC_GHOST_SPECIFIER_P(sp) && obj_marked_p (sp->magic_parent))); /* This specifier is garbage. Remove it from the list. */ if (GC_NILP (prev)) Vall_specifiers = sp->next_specifier; @@ -287,10 +287,10 @@ finalize_specifier (void *header, int for_disksave) } static int -specifier_equal (Lisp_Object o1, Lisp_Object o2, int depth) +specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Specifier *s1 = XSPECIFIER (o1); - struct Lisp_Specifier *s2 = XSPECIFIER (o2); + struct Lisp_Specifier *s1 = XSPECIFIER (obj1); + struct Lisp_Specifier *s2 = XSPECIFIER (obj2); int retval; Lisp_Object old_inhibit_quit = Vinhibit_quit; @@ -309,7 +309,7 @@ specifier_equal (Lisp_Object o1, Lisp_Object o2, int depth) internal_equal (s1->fallback, s2->fallback, depth)); if (retval && HAS_SPECMETH_P (s1, equal)) - retval = SPECMETH (s1, equal, (o1, o2, depth - 1)); + retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1)); Vinhibit_quit = old_inhibit_quit; return retval; @@ -637,16 +637,21 @@ decode_locale_list (Lisp_Object locale) /* This cannot GC. */ /* The return value of this function must be GCPRO'd. */ if (NILP (locale)) - locale = list1 (Qall); + { + return list1 (Qall); + } + else if (CONSP (locale)) + { + Lisp_Object elt; + EXTERNAL_LIST_LOOP_2 (elt, locale) + check_valid_locale_or_locale_type (elt); + return locale; + } else { - Lisp_Object rest; - if (!CONSP (locale)) - locale = list1 (locale); - EXTERNAL_LIST_LOOP (rest, locale) - check_valid_locale_or_locale_type (XCAR (rest)); + check_valid_locale_or_locale_type (locale); + return list1 (locale); } - return locale; } static enum spec_locale_type @@ -1846,7 +1851,7 @@ with the function `specifier-spec-list' or `specifier-specs'. CHECK_SPECIFIER (specifier); check_modifiable_specifier (specifier); - + locale = decode_locale (locale); check_valid_instantiator (instantiator, decode_specifier_type @@ -2405,18 +2410,17 @@ specifier_instance_from_inst_list (Lisp_Object specifier, specific (buffer) to most general (global). If we find an instance, return it. Otherwise return Qunbound. */ -#define CHECK_INSTANCE_ENTRY(key, matchspec, type) \ -do { \ - Lisp_Object *__inst_list = \ +#define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ + Lisp_Object *CIE_inst_list = \ specifier_get_inst_list (specifier, key, type); \ - if (__inst_list) \ + if (CIE_inst_list) \ { \ - Lisp_Object __val__ = \ + Lisp_Object CIE_val = \ specifier_instance_from_inst_list (specifier, matchspec, \ - domain, *__inst_list, \ + domain, *CIE_inst_list, \ errb, no_quit, depth); \ - if (!UNBOUNDP (__val__)) \ - return __val__; \ + if (!UNBOUNDP (CIE_val)) \ + return CIE_val; \ } \ } while (0) @@ -2480,7 +2484,7 @@ specifier_instance (Lisp_Object specifier, Lisp_Object matchspec, goto do_fallback; } -try_again: +retry: /* First see if we can generate one from the window specifiers. */ if (!NILP (window)) CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); @@ -2514,7 +2518,7 @@ do_fallback: then you're fucked, so you better not do this. */ specifier = sp->fallback; sp = XSPECIFIER (specifier); - goto try_again; + goto retry; } assert (CONSP (sp->fallback)); @@ -3126,7 +3130,7 @@ vars_of_specifier (void) staticpro (&Vcached_specifiers); /* Do NOT mark through this, or specifiers will never be GC'd. - This is the same deal as for weak hashtables. */ + This is the same deal as for weak hash tables. */ Vall_specifiers = Qnil; Vuser_defined_tags = Qnil; diff --git a/src/specifier.h b/src/specifier.h index 14c4cf1..674be41 100644 --- a/src/specifier.h +++ b/src/specifier.h @@ -34,7 +34,7 @@ Boston, MA 02111-1307, USA. */ etc. A magic specifier consists of two specifier objects. The first one - behaves like a normal specifier in all sences. The second one, a + behaves like a normal specifier in all senses. The second one, a ghost specifier, is a fallback value for the first one, and contains values provided by window system, resources etc. which reflect default settings for values being specified. @@ -61,11 +61,11 @@ Boston, MA 02111-1307, USA. */ frame defaults, such as init-{global,frame,device}-{faces,toolbars,etc}. - Thus, values supplied by resources or other means of a window system + Thus, values supplied by resources or other means of a window system stored in externally unmodifiable ghost objects. Regular lisp code may thus freely modify the normal part of a magic specifier, and removing a specification for a particular domain causes the - specification to consider ghost-provided fallback values, or its own + specification to consider ghost-provided fallback values, or its own fallback value. Rules of conduct for magic specifiers @@ -76,10 +76,10 @@ Boston, MA 02111-1307, USA. */ 2. All specifier methods, except for instantiate method, are passed the bodily object of the magic specifier. Instantiate method is passed the specifier being instantiated. - 3. Only bodily objects are passed to set_specifier_caching function, + 3. Only bodily objects are passed to set_specifier_caching function, and only these may be cached. - 4. All specifiers are added to Vall_specifiers list, both bodily and - ghost. The pair of objects is always removed from the list at the + 4. All specifiers are added to Vall_specifiers list, both bodily and + ghost. The pair of objects is always removed from the list at the same time. */ @@ -98,7 +98,7 @@ struct specifier_methods void (*mark_method) (Lisp_Object specifier, void (*markobj) (Lisp_Object)); /* Equal method: Compare two specifiers. This is called after - ensuring that the two specifiers are of the same type, and habe + ensuring that the two specifiers are of the same type, and have the same specs. Quit is inhibited during the call so it is safe to call internal_equal(). @@ -220,7 +220,7 @@ struct Lisp_Specifier the ghost part of the magic specifier, a pointer to its parent object */ Lisp_Object magic_parent; - + /* Fallback value. For magic specifiers, it is a pointer to the ghost. */ Lisp_Object fallback; @@ -244,9 +244,9 @@ DECLARE_LRECORD (specifier, struct Lisp_Specifier); /* Call a void-returning specifier method, if it exists. */ #define MAYBE_SPECMETH(sp, m, args) do { \ - struct Lisp_Specifier *_maybe_specmeth_sp = (sp); \ - if (HAS_SPECMETH_P (_maybe_specmeth_sp, m)) \ - SPECMETH (_maybe_specmeth_sp, m, args); \ + struct Lisp_Specifier *maybe_specmeth_sp = (sp); \ + if (HAS_SPECMETH_P (maybe_specmeth_sp, m)) \ + SPECMETH (maybe_specmeth_sp, m, args); \ } while (0) /***** Defining new specifier types *****/ diff --git a/src/sunplay.c b/src/sunplay.c index 631d044..4df9d68 100644 --- a/src/sunplay.c +++ b/src/sunplay.c @@ -61,7 +61,7 @@ static SIGTYPE sighandler (int sig); static int audio_fd; -#define audio_open() open ("/dev/audio", (O_WRONLY | O_NDELAY), 0) +#define audio_open() open ("/dev/audio", (O_WRONLY | O_NONBLOCK), 0) static int reset_volume_p, reset_device_p; static double old_volume; diff --git a/src/symbols.c b/src/symbols.c index 1ecc2d0..39859a3 100644 --- a/src/symbols.c +++ b/src/symbols.c @@ -56,8 +56,7 @@ Boston, MA 02111-1307, USA. */ #include "buffer.h" /* for Vbuffer_defaults */ #include "console.h" - -#include "elhash.h" /* for HASHTABLE_NONWEAK and HASHTABLE_EQ */ +#include "elhash.h" Lisp_Object Qad_advice_info, Qad_activate; @@ -66,7 +65,8 @@ Lisp_Object Qlocal_predicate, Qmake_local; Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound; Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value; -Lisp_Object Qset_default, Qmake_variable_buffer_local, Qmake_local_variable; +Lisp_Object Qset_default, Qsetq_default; +Lisp_Object Qmake_variable_buffer_local, Qmake_local_variable; Lisp_Object Qkill_local_variable, Qkill_console_local_variable; Lisp_Object Qsymbol_value_in_buffer, Qsymbol_value_in_console; Lisp_Object Qlocal_variable_p; @@ -80,12 +80,10 @@ static Lisp_Object maybe_call_magic_handler (Lisp_Object sym, Lisp_Object funsym, int nargs, ...); static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym, - Lisp_Object - follow_past_lisp_magic); + Lisp_Object follow_past_lisp_magic); static Lisp_Object *value_slot_past_magic (Lisp_Object sym); -static Lisp_Object follow_varalias_pointers (Lisp_Object object, - Lisp_Object - follow_past_lisp_magic); +static Lisp_Object follow_varalias_pointers (Lisp_Object symbol, + Lisp_Object follow_past_lisp_magic); #ifdef LRECORD_SYMBOL @@ -96,17 +94,17 @@ mark_symbol (Lisp_Object obj, void (*markobj) (Lisp_Object)) struct Lisp_Symbol *sym = XSYMBOL (obj); Lisp_Object pname; - ((markobj) (sym->value)); - ((markobj) (sym->function)); + markobj (sym->value); + markobj (sym->function); /* No need to mark through ->obarray, because it only holds nil or t. */ - /*((markobj) (sym->obarray));*/ + /* markobj (sym->obarray);*/ XSETSTRING (pname, sym->name); - ((markobj) (pname)); + markobj (pname); if (!symbol_next (sym)) return sym->plist; else { - ((markobj) (sym->plist)); + markobj (sym->plist); /* Mark the rest of the symbols in the obarray hash-chain */ sym = symbol_next (sym); XSETSYMBOL (obj, sym); @@ -150,18 +148,22 @@ check_obarray (Lisp_Object obarray) Lisp_Object intern (CONST char *str) { - Lisp_Object tem; Bytecount len = strlen (str); + CONST Bufbyte *buf = (CONST Bufbyte *) str; Lisp_Object obarray = Vobarray; + if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0) obarray = check_obarray (obarray); - tem = oblookup (obarray, (CONST Bufbyte *) str, len); - if (SYMBOLP (tem)) - return tem; - return Fintern (((purify_flag) - ? make_pure_pname ((CONST Bufbyte *) str, len, 0) - : make_string ((CONST Bufbyte *) str, len)), + { + Lisp_Object tem = oblookup (obarray, buf, len); + if (SYMBOLP (tem)) + return tem; + } + + return Fintern ((purify_flag + ? make_pure_pname (buf, len, 0) + : make_string (buf, len)), obarray); } @@ -171,7 +173,7 @@ If there is none, one is created by this function and returned. A second optional argument specifies the obarray to use; it defaults to the value of `obarray'. */ - (str, obarray)) + (string, obarray)) { Lisp_Object sym, *ptr; Bytecount len; @@ -179,19 +181,19 @@ it defaults to the value of `obarray'. if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); - CHECK_STRING (str); + CHECK_STRING (string); - len = XSTRING_LENGTH (str); - sym = oblookup (obarray, XSTRING_DATA (str), len); + len = XSTRING_LENGTH (string); + sym = oblookup (obarray, XSTRING_DATA (string), len); if (!INTP (sym)) /* Found it */ return sym; ptr = &XVECTOR_DATA (obarray)[XINT (sym)]; - if (purify_flag && ! purified (str)) - str = make_pure_pname (XSTRING_DATA (str), len, 0); - sym = Fmake_symbol (str); + if (purify_flag && ! purified (string)) + string = make_pure_pname (XSTRING_DATA (string), len, 0); + sym = Fmake_symbol (string); /* FSFmacs places OBARRAY here, but it is pointless because we do not mark through this slot, so it is not usable later (because the obarray might have been collected). Marking through the @@ -217,19 +219,17 @@ Return the canonical symbol whose name is STRING, or nil if none exists. A second optional argument specifies the obarray to use; it defaults to the value of `obarray'. */ - (str, obarray)) + (string, obarray)) { Lisp_Object tem; if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); - CHECK_STRING (str); + CHECK_STRING (string); - tem = oblookup (obarray, XSTRING_DATA (str), XSTRING_LENGTH (str)); - if (!INTP (tem)) - return tem; - return Qnil; + tem = oblookup (obarray, XSTRING_DATA (string), XSTRING_LENGTH (string)); + return !INTP (tem) ? tem : Qnil; } DEFUN ("unintern", Funintern, 1, 2, 0, /* @@ -293,7 +293,7 @@ OBARRAY defaults to the value of the variable `obarray' /* Return the symbol in OBARRAY whose names matches the string of SIZE characters at PTR. If there is no such symbol in OBARRAY, - return nil. + return the index into OBARRAY that the string hashes to. Also store the bucket number in oblookup_last_bucket_number. */ @@ -315,11 +315,9 @@ oblookup (Lisp_Object obarray, CONST Bufbyte *ptr, Bytecount size) /* This is sometimes needed in the middle of GC. */ obsize &= ~ARRAY_MARK_FLAG; #endif - /* Combining next two lines breaks VMS C 2.3. */ - hash = hash_string (ptr, size); - hash %= obsize; - bucket = XVECTOR_DATA (obarray)[hash]; + hash = hash_string (ptr, size) % obsize; oblookup_last_bucket_number = hash; + bucket = XVECTOR_DATA (obarray)[hash]; if (ZEROP (bucket)) ; else if (!SYMBOLP (bucket)) @@ -484,29 +482,29 @@ static void set_up_buffer_local_cache (Lisp_Object sym, DEFUN ("boundp", Fboundp, 1, 1, 0, /* Return t if SYMBOL's value is not void. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return UNBOUNDP (find_symbol_value (sym)) ? Qnil : Qt; + CHECK_SYMBOL (symbol); + return UNBOUNDP (find_symbol_value (symbol)) ? Qnil : Qt; } DEFUN ("globally-boundp", Fglobally_boundp, 1, 1, 0, /* Return t if SYMBOL has a global (non-bound) value. This is for the byte-compiler; you really shouldn't be using this. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return UNBOUNDP (top_level_value (sym)) ? Qnil : Qt; + CHECK_SYMBOL (symbol); + return UNBOUNDP (top_level_value (symbol)) ? Qnil : Qt; } DEFUN ("fboundp", Ffboundp, 1, 1, 0, /* Return t if SYMBOL's function definition is not void. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return UNBOUNDP (XSYMBOL (sym)->function) ? Qnil : Qt; + CHECK_SYMBOL (symbol); + return UNBOUNDP (XSYMBOL (symbol)->function) ? Qnil : Qt; } /* Return non-zero if SYM's value or function (the current contents of @@ -537,7 +535,7 @@ symbol_is_constant (Lisp_Object sym, Lisp_Object val) } /* We don't return true for keywords here because they are handled - specially by reject_constant_symbols(). */ + specially by reject_constant_symbols(). */ return 0; } @@ -546,7 +544,7 @@ symbol_is_constant (Lisp_Object sym, Lisp_Object val) FOLLOW_PAST_LISP_MAGIC specifies whether we delve past symbol-value-lisp-magic objects. */ -static void +void reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, int function_p, Lisp_Object follow_past_lisp_magic) { @@ -603,21 +601,21 @@ verify_ok_for_buffer_local (Lisp_Object sym, DEFUN ("makunbound", Fmakunbound, 1, 1, 0, /* Make SYMBOL's value be void. */ - (sym)) + (symbol)) { - Fset (sym, Qunbound); - return sym; + Fset (symbol, Qunbound); + return symbol; } DEFUN ("fmakunbound", Ffmakunbound, 1, 1, 0, /* Make SYMBOL's function definition be void. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - reject_constant_symbols (sym, Qunbound, 1, Qt); - XSYMBOL (sym)->function = Qunbound; - return sym; + CHECK_SYMBOL (symbol); + reject_constant_symbols (symbol, Qunbound, 1, Qt); + XSYMBOL (symbol)->function = Qunbound; + return symbol; } DEFUN ("symbol-function", Fsymbol_function, 1, 1, 0, /* @@ -627,49 +625,49 @@ Return SYMBOL's function definition. Error if that is void. { CHECK_SYMBOL (symbol); if (UNBOUNDP (XSYMBOL (symbol)->function)) - return Fsignal (Qvoid_function, list1 (symbol)); + signal_void_function_error (symbol); return XSYMBOL (symbol)->function; } DEFUN ("symbol-plist", Fsymbol_plist, 1, 1, 0, /* Return SYMBOL's property list. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return XSYMBOL (sym)->plist; + CHECK_SYMBOL (symbol); + return XSYMBOL (symbol)->plist; } DEFUN ("symbol-name", Fsymbol_name, 1, 1, 0, /* Return SYMBOL's name, a string. */ - (sym)) + (symbol)) { Lisp_Object name; - CHECK_SYMBOL (sym); - XSETSTRING (name, XSYMBOL (sym)->name); + CHECK_SYMBOL (symbol); + XSETSTRING (name, XSYMBOL (symbol)->name); return name; } DEFUN ("fset", Ffset, 2, 2, 0, /* Set SYMBOL's function definition to NEWDEF, and return NEWDEF. */ - (sym, newdef)) + (symbol, newdef)) { /* This function can GC */ - CHECK_SYMBOL (sym); - reject_constant_symbols (sym, newdef, 1, Qt); - if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (sym)->function)) - Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), + CHECK_SYMBOL (symbol); + reject_constant_symbols (symbol, newdef, 1, Qt); + if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (symbol)->function)) + Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function), Vautoload_queue); - XSYMBOL (sym)->function = newdef; + XSYMBOL (symbol)->function = newdef; /* Handle automatic advice activation */ - if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info, - Qnil))) + if (CONSP (XSYMBOL (symbol)->plist) && + !NILP (Fget (symbol, Qad_advice_info, Qnil))) { - call2 (Qad_activate, sym, Qnil); - newdef = XSYMBOL (sym)->function; + call2 (Qad_activate, symbol, Qnil); + newdef = XSYMBOL (symbol)->function; } return newdef; } @@ -679,12 +677,11 @@ DEFUN ("define-function", Fdefine_function, 2, 2, 0, /* Set SYMBOL's function definition to NEWDEF, and return NEWDEF. Associates the function with the current load file, if any. */ - (sym, newdef)) + (symbol, newdef)) { /* This function can GC */ - CHECK_SYMBOL (sym); - Ffset (sym, newdef); - LOADHIST_ATTACH (sym); + Ffset (symbol, newdef); + LOADHIST_ATTACH (symbol); return newdef; } @@ -692,16 +689,16 @@ Associates the function with the current load file, if any. DEFUN ("setplist", Fsetplist, 2, 2, 0, /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */ - (sym, newplist)) + (symbol, newplist)) { - CHECK_SYMBOL (sym); + CHECK_SYMBOL (symbol); #if 0 /* Inserted for debugging 6/28/1997 -slb */ /* Somebody is setting a property list of integer 0, who? */ /* Not this way apparently. */ if (EQ(newplist, Qzero)) abort(); #endif - XSYMBOL (sym)->plist = newplist; + XSYMBOL (symbol)->plist = newplist; return newplist; } @@ -719,7 +716,7 @@ Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. If a symbol is "unbound", then the contents of its value cell is Qunbound. Despite appearances, this is *not* a symbol, but is a symbol-value-forward object. This is so that printing it results - in "INTERNAL EMACS BUG", in case it leaks to Lisp, somehow. + in "INTERNAL OBJECT (XEmacs bug?)", in case it leaks to Lisp, somehow. Logically all of the following objects are "symbol-value-magic" objects, and there are some games played w.r.t. this (#### this @@ -900,13 +897,15 @@ mark_symbol_value_buffer_local (Lisp_Object obj, { struct symbol_value_buffer_local *bfwd; +#ifdef ERROR_CHECK_TYPECHECK assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_BUFFER_LOCAL || XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_SOME_BUFFER_LOCAL); +#endif bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj); - ((markobj) (bfwd->default_value)); - ((markobj) (bfwd->current_value)); - ((markobj) (bfwd->current_buffer)); + markobj (bfwd->default_value); + markobj (bfwd->current_value); + markobj (bfwd->current_buffer); return bfwd->current_alist_element; } @@ -922,8 +921,8 @@ mark_symbol_value_lisp_magic (Lisp_Object obj, bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj); for (i = 0; i < MAGIC_HANDLER_MAX; i++) { - ((markobj) (bfwd->handler[i])); - ((markobj) (bfwd->harg[i])); + markobj (bfwd->handler[i]); + markobj (bfwd->harg[i]); } return bfwd->shadowed; } @@ -937,7 +936,7 @@ mark_symbol_value_varalias (Lisp_Object obj, assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS); bfwd = XSYMBOL_VALUE_VARALIAS (obj); - ((markobj) (bfwd->shadowed)); + markobj (bfwd->shadowed); return bfwd->aliasee; } @@ -947,10 +946,10 @@ print_symbol_value_magic (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { char buf[200]; - sprintf (buf, "#", + sprintf (buf, "#", XRECORD_LHEADER_IMPLEMENTATION (obj)->name, XSYMBOL_VALUE_MAGIC_TYPE (obj), - (void *) XPNTR (obj)); + (long) XPNTR (obj)); write_c_string (buf, printcharfun); } @@ -1081,16 +1080,16 @@ set_default_buffer_slot_variable (Lisp_Object sym, if (mask > 0) /* Not always per-buffer */ { - Lisp_Object tail; + Lisp_Object elt; /* Set value in each buffer which hasn't shadowed the default */ - LIST_LOOP (tail, Vbuffer_alist) + LIST_LOOP_2 (elt, Vbuffer_alist) { - struct buffer *b = XBUFFER (XCDR (XCAR (tail))); + struct buffer *b = XBUFFER (XCDR (elt)); if (!(b->local_var_flags & mask)) { if (magicfun) - (magicfun) (sym, &value, make_buffer (b), 0); + magicfun (sym, &value, make_buffer (b), 0); *((Lisp_Object *) (offset + (char *) b)) = value; } } @@ -1123,17 +1122,16 @@ set_default_console_slot_variable (Lisp_Object sym, if (mask > 0) /* Not always per-console */ { - Lisp_Object tail; + Lisp_Object console; /* Set value in each console which hasn't shadowed the default */ - LIST_LOOP (tail, Vconsole_list) + LIST_LOOP_2 (console, Vconsole_list) { - Lisp_Object dev = XCAR (tail); - struct console *d = XCONSOLE (dev); + struct console *d = XCONSOLE (console); if (!(d->local_var_flags & mask)) { if (magicfun) - (magicfun) (sym, &value, dev, 0); + magicfun (sym, &value, console, 0); *((Lisp_Object *) (offset + (char *) d)) = value; } } @@ -1175,77 +1173,60 @@ store_symval_forwarding (Lisp_Object sym, Lisp_Object ovalue, || !SYMBOL_VALUE_MAGIC_P (*store_pointer)); *store_pointer = newval; } - else { - CONST struct symbol_value_forward *fwd - = XSYMBOL_VALUE_FORWARD (ovalue); - int type = XSYMBOL_VALUE_MAGIC_TYPE (ovalue); + CONST struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (ovalue); int (*magicfun) (Lisp_Object simm, Lisp_Object *val, - Lisp_Object in_object, int flags) = - symbol_value_forward_magicfun (fwd); + Lisp_Object in_object, int flags) + = symbol_value_forward_magicfun (fwd); - switch (type) + switch (XSYMBOL_VALUE_MAGIC_TYPE (ovalue)) { case SYMVAL_FIXNUM_FORWARD: - { - CHECK_INT (newval); - if (magicfun) - (magicfun) (sym, &newval, Qnil, 0); - *((int *) symbol_value_forward_forward (fwd)) = XINT (newval); - return; - } + CHECK_INT (newval); + if (magicfun) + magicfun (sym, &newval, Qnil, 0); + *((int *) symbol_value_forward_forward (fwd)) = XINT (newval); + return; case SYMVAL_BOOLEAN_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, Qnil, 0); - *((int *) symbol_value_forward_forward (fwd)) - = ((NILP (newval)) ? 0 : 1); - return; - } + if (magicfun) + magicfun (sym, &newval, Qnil, 0); + *((int *) symbol_value_forward_forward (fwd)) + = ((NILP (newval)) ? 0 : 1); + return; case SYMVAL_OBJECT_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, Qnil, 0); - *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval; - return; - } + if (magicfun) + magicfun (sym, &newval, Qnil, 0); + *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval; + return; case SYMVAL_DEFAULT_BUFFER_FORWARD: - { - set_default_buffer_slot_variable (sym, newval); - return; - } + set_default_buffer_slot_variable (sym, newval); + return; case SYMVAL_CURRENT_BUFFER_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, make_buffer (current_buffer), 0); - *((Lisp_Object *) ((char *) current_buffer - + ((char *) symbol_value_forward_forward (fwd) - - (char *) &buffer_local_flags))) - = newval; - return; - } + if (magicfun) + magicfun (sym, &newval, make_buffer (current_buffer), 0); + *((Lisp_Object *) ((char *) current_buffer + + ((char *) symbol_value_forward_forward (fwd) + - (char *) &buffer_local_flags))) + = newval; + return; case SYMVAL_DEFAULT_CONSOLE_FORWARD: - { - set_default_console_slot_variable (sym, newval); - return; - } + set_default_console_slot_variable (sym, newval); + return; case SYMVAL_SELECTED_CONSOLE_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, Vselected_console, 0); - *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console) - + ((char *) symbol_value_forward_forward (fwd) - - (char *) &console_local_flags))) - = newval; - return; - } + if (magicfun) + magicfun (sym, &newval, Vselected_console, 0); + *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console) + + ((char *) symbol_value_forward_forward (fwd) + - (char *) &console_local_flags))) + = newval; + return; default: abort (); @@ -1335,7 +1316,7 @@ set_up_buffer_local_cache (Lisp_Object sym, /* Retrieve the new alist element and new value. */ if (NILP (new_alist_el) && set_it_p) - new_alist_el = buffer_local_alist_element (buf, sym, bfwd); + new_alist_el = buffer_local_alist_element (buf, sym, bfwd); if (NILP (new_alist_el)) new_val = bfwd->default_value; @@ -1460,7 +1441,7 @@ find_symbol_value_1 (Lisp_Object sym, struct buffer *buf, else if (NILP (symcons)) { if (set_it_p) - valcontents = assq_no_quit (sym, buf->local_var_alist); + valcontents = assq_no_quit (sym, buf->local_var_alist); if (NILP (valcontents)) valcontents = bfwd->default_value; else @@ -1490,13 +1471,13 @@ symbol_value_in_buffer (Lisp_Object sym, Lisp_Object buffer) CHECK_SYMBOL (sym); - if (!NILP (buffer)) + if (NILP (buffer)) + buf = current_buffer; + else { CHECK_BUFFER (buffer); buf = XBUFFER (buffer); } - else - buf = current_buffer; return find_symbol_value_1 (sym, buf, /* If it bombs out at startup due to a @@ -1510,10 +1491,10 @@ symbol_value_in_console (Lisp_Object sym, Lisp_Object console) { CHECK_SYMBOL (sym); - if (!NILP (console)) - CHECK_CONSOLE (console); - else + if (NILP (console)) console = Vselected_console; + else + CHECK_CONSOLE (console); return find_symbol_value_1 (sym, current_buffer, XCONSOLE (console), 0, Qnil, 1); @@ -1529,7 +1510,7 @@ find_symbol_value (Lisp_Object sym) { /* WARNING: This function can be called when current_buffer is 0 and Vselected_console is Qnil, early in initialization. */ - struct console *dev; + struct console *con; Lisp_Object valcontents; CHECK_SYMBOL (sym); @@ -1539,17 +1520,17 @@ find_symbol_value (Lisp_Object sym) return valcontents; if (CONSOLEP (Vselected_console)) - dev = XCONSOLE (Vselected_console); + con = XCONSOLE (Vselected_console); else { /* This can also get called while we're preparing to shutdown. #### What should really happen in that case? Should we actually fix things so we can't get here in that case? */ assert (!initialized || preparing_for_armageddon); - dev = 0; + con = 0; } - return find_symbol_value_1 (sym, current_buffer, dev, 1, Qnil, 1); + return find_symbol_value_1 (sym, current_buffer, con, 1, Qnil, 1); } /* This is an optimized function for quick lookup of buffer local symbols @@ -1570,22 +1551,22 @@ find_symbol_value_quickly (Lisp_Object symbol_cons, int find_it_p) { /* WARNING: This function can be called when current_buffer is 0 and Vselected_console is Qnil, early in initialization. */ - struct console *dev; + struct console *con; Lisp_Object sym = find_it_p ? XCAR (symbol_cons) : symbol_cons; CHECK_SYMBOL (sym); if (CONSOLEP (Vselected_console)) - dev = XCONSOLE (Vselected_console); + con = XCONSOLE (Vselected_console); else { /* This can also get called while we're preparing to shutdown. #### What should really happen in that case? Should we actually fix things so we can't get here in that case? */ assert (!initialized || preparing_for_armageddon); - dev = 0; + con = 0; } - return find_symbol_value_1 (sym, current_buffer, dev, 1, + return find_symbol_value_1 (sym, current_buffer, con, 1, find_it_p ? symbol_cons : Qnil, find_it_p); } @@ -1593,12 +1574,12 @@ find_symbol_value_quickly (Lisp_Object symbol_cons, int find_it_p) DEFUN ("symbol-value", Fsymbol_value, 1, 1, 0, /* Return SYMBOL's value. Error if that is void. */ - (sym)) + (symbol)) { - Lisp_Object val = find_symbol_value (sym); + Lisp_Object val = find_symbol_value (symbol); if (UNBOUNDP (val)) - return Fsignal (Qvoid_variable, list1 (sym)); + return Fsignal (Qvoid_variable, list1 (symbol)); else return val; } @@ -1606,177 +1587,181 @@ Return SYMBOL's value. Error if that is void. DEFUN ("set", Fset, 2, 2, 0, /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */ - (sym, newval)) + (symbol, newval)) { REGISTER Lisp_Object valcontents; + struct Lisp_Symbol *sym; /* remember, we're called by Fmakunbound() as well */ - CHECK_SYMBOL (sym); + CHECK_SYMBOL (symbol); retry: - valcontents = XSYMBOL (sym)->value; - if (NILP (sym) || EQ (sym, Qt) || SYMBOL_VALUE_MAGIC_P (valcontents) - || SYMBOL_IS_KEYWORD (sym)) - reject_constant_symbols (sym, newval, 0, + sym = XSYMBOL (symbol); + valcontents = sym->value; + + if (EQ (symbol, Qnil) || + EQ (symbol, Qt) || + SYMBOL_IS_KEYWORD (symbol)) + reject_constant_symbols (symbol, newval, 0, UNBOUNDP (newval) ? Qmakunbound : Qset); - else + + if (!SYMBOL_VALUE_MAGIC_P (valcontents) || UNBOUNDP (valcontents)) { - XSYMBOL (sym)->value = newval; + sym->value = newval; return newval; } + reject_constant_symbols (symbol, newval, 0, + UNBOUNDP (newval) ? Qmakunbound : Qset); + retry_2: - if (SYMBOL_VALUE_MAGIC_P (valcontents)) + switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) { - switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) - { - case SYMVAL_LISP_MAGIC: - { - Lisp_Object retval; + case SYMVAL_LISP_MAGIC: + { + Lisp_Object retval; - if (UNBOUNDP (newval)) - retval = maybe_call_magic_handler (sym, Qmakunbound, 0); - else - retval = maybe_call_magic_handler (sym, Qset, 1, newval); - if (!UNBOUNDP (retval)) - return newval; - valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; - /* semi-change-o */ - goto retry_2; - } + if (UNBOUNDP (newval)) + retval = maybe_call_magic_handler (symbol, Qmakunbound, 0); + else + retval = maybe_call_magic_handler (symbol, Qset, 1, newval); + if (!UNBOUNDP (retval)) + return newval; + valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; + /* semi-change-o */ + goto retry_2; + } - case SYMVAL_VARALIAS: - sym = follow_varalias_pointers (sym, - UNBOUNDP (newval) - ? Qmakunbound : Qset); - /* presto change-o! */ - goto retry; + case SYMVAL_VARALIAS: + symbol = follow_varalias_pointers (symbol, + UNBOUNDP (newval) + ? Qmakunbound : Qset); + /* presto change-o! */ + goto retry; - case SYMVAL_FIXNUM_FORWARD: - case SYMVAL_BOOLEAN_FORWARD: - case SYMVAL_OBJECT_FORWARD: - case SYMVAL_DEFAULT_BUFFER_FORWARD: - case SYMVAL_DEFAULT_CONSOLE_FORWARD: - if (UNBOUNDP (newval)) - signal_error (Qerror, - list2 (build_string ("Cannot makunbound"), sym)); - break; + case SYMVAL_FIXNUM_FORWARD: + case SYMVAL_BOOLEAN_FORWARD: + case SYMVAL_OBJECT_FORWARD: + case SYMVAL_DEFAULT_BUFFER_FORWARD: + case SYMVAL_DEFAULT_CONSOLE_FORWARD: + if (UNBOUNDP (newval)) + signal_error (Qerror, + list2 (build_string ("Cannot makunbound"), symbol)); + break; - case SYMVAL_UNBOUND_MARKER: - break; + /* case SYMVAL_UNBOUND_MARKER: break; */ - case SYMVAL_CURRENT_BUFFER_FORWARD: - { - CONST struct symbol_value_forward *fwd - = XSYMBOL_VALUE_FORWARD (valcontents); - int mask = XINT (*((Lisp_Object *) - symbol_value_forward_forward (fwd))); - if (mask > 0) - /* Setting this variable makes it buffer-local */ - current_buffer->local_var_flags |= mask; - break; - } + case SYMVAL_CURRENT_BUFFER_FORWARD: + { + CONST struct symbol_value_forward *fwd + = XSYMBOL_VALUE_FORWARD (valcontents); + int mask = XINT (*((Lisp_Object *) + symbol_value_forward_forward (fwd))); + if (mask > 0) + /* Setting this variable makes it buffer-local */ + current_buffer->local_var_flags |= mask; + break; + } - case SYMVAL_SELECTED_CONSOLE_FORWARD: + case SYMVAL_SELECTED_CONSOLE_FORWARD: + { + CONST struct symbol_value_forward *fwd + = XSYMBOL_VALUE_FORWARD (valcontents); + int mask = XINT (*((Lisp_Object *) + symbol_value_forward_forward (fwd))); + if (mask > 0) + /* Setting this variable makes it console-local */ + XCONSOLE (Vselected_console)->local_var_flags |= mask; + break; + } + + case SYMVAL_BUFFER_LOCAL: + case SYMVAL_SOME_BUFFER_LOCAL: + { + /* If we want to examine or set the value and + CURRENT-BUFFER is current, we just examine or set + CURRENT-VALUE. If CURRENT-BUFFER is not current, we + store the current CURRENT-VALUE value into + CURRENT-ALIST- ELEMENT, then find the appropriate alist + element for the buffer now current and set up + CURRENT-ALIST-ELEMENT. Then we set CURRENT-VALUE out + of that element, and store into CURRENT-BUFFER. + + If we are setting the variable and the current buffer does + not have an alist entry for this variable, an alist entry is + created. + + Note that CURRENT-VALUE can be a forwarding pointer. + Each time it is examined or set, forwarding must be + done. */ + struct symbol_value_buffer_local *bfwd + = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents); + int some_buffer_local_p = + (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL); + /* What value are we caching right now? */ + Lisp_Object aelt = bfwd->current_alist_element; + + if (!NILP (bfwd->current_buffer) && + current_buffer == XBUFFER (bfwd->current_buffer) + && ((some_buffer_local_p) + ? 1 /* doesn't automatically become local */ + : !NILP (aelt) /* already local */ + )) { - CONST struct symbol_value_forward *fwd - = XSYMBOL_VALUE_FORWARD (valcontents); - int mask = XINT (*((Lisp_Object *) - symbol_value_forward_forward (fwd))); - if (mask > 0) - /* Setting this variable makes it console-local */ - XCONSOLE (Vselected_console)->local_var_flags |= mask; - break; + /* Cache is valid */ + valcontents = bfwd->current_value; } - - case SYMVAL_BUFFER_LOCAL: - case SYMVAL_SOME_BUFFER_LOCAL: + else { - /* If we want to examine or set the value and - CURRENT-BUFFER is current, we just examine or set - CURRENT-VALUE. If CURRENT-BUFFER is not current, we - store the current CURRENT-VALUE value into - CURRENT-ALIST- ELEMENT, then find the appropriate alist - element for the buffer now current and set up - CURRENT-ALIST-ELEMENT. Then we set CURRENT-VALUE out - of that element, and store into CURRENT-BUFFER. - - If we are setting the variable and the current buffer does - not have an alist entry for this variable, an alist entry is - created. - - Note that CURRENT-VALUE can be a forwarding pointer. - Each time it is examined or set, forwarding must be - done. */ - struct symbol_value_buffer_local *bfwd - = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents); - int some_buffer_local_p = - (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL); - /* What value are we caching right now? */ - Lisp_Object aelt = bfwd->current_alist_element; - - if (!NILP (bfwd->current_buffer) && - current_buffer == XBUFFER (bfwd->current_buffer) - && ((some_buffer_local_p) - ? 1 /* doesn't automatically become local */ - : !NILP (aelt) /* already local */ - )) + /* If the current buffer is not the buffer whose binding is + currently cached, or if it's a SYMVAL_BUFFER_LOCAL and + we're looking at the default value, the cache is invalid; we + need to write it out, and find the new CURRENT-ALIST-ELEMENT + */ + + /* Write out the cached value for the old buffer; copy it + back to its alist element. This works if the current + buffer only sees the default value, too. */ + write_out_buffer_local_cache (symbol, bfwd); + + /* Find the new value for CURRENT-ALIST-ELEMENT. */ + aelt = buffer_local_alist_element (current_buffer, symbol, bfwd); + if (NILP (aelt)) { - /* Cache is valid */ - valcontents = bfwd->current_value; - } - else - { - /* If the current buffer is not the buffer whose binding is - currently cached, or if it's a SYMVAL_BUFFER_LOCAL and - we're looking at the default value, the cache is invalid; we - need to write it out, and find the new CURRENT-ALIST-ELEMENT - */ - - /* Write out the cached value for the old buffer; copy it - back to its alist element. This works if the current - buffer only sees the default value, too. */ - write_out_buffer_local_cache (sym, bfwd); - - /* Find the new value for CURRENT-ALIST-ELEMENT. */ - aelt = buffer_local_alist_element (current_buffer, sym, bfwd); - if (NILP (aelt)) + /* This buffer is still seeing the default value. */ + if (!some_buffer_local_p) + { + /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a + new assoc for a local value and set + CURRENT-ALIST-ELEMENT to point to that. */ + aelt = + do_symval_forwarding (bfwd->current_value, + current_buffer, + XCONSOLE (Vselected_console)); + aelt = Fcons (symbol, aelt); + current_buffer->local_var_alist + = Fcons (aelt, current_buffer->local_var_alist); + } + else { - /* This buffer is still seeing the default value. */ - if (!some_buffer_local_p) - { - /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a - new assoc for a local value and set - CURRENT-ALIST-ELEMENT to point to that. */ - aelt = - do_symval_forwarding (bfwd->current_value, - current_buffer, - XCONSOLE (Vselected_console)); - aelt = Fcons (sym, aelt); - current_buffer->local_var_alist - = Fcons (aelt, current_buffer->local_var_alist); - } - else - { - /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL, - we're currently seeing the default value. */ - ; - } + /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL, + we're currently seeing the default value. */ + ; } - /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ - bfwd->current_alist_element = aelt; - /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */ - XSETBUFFER (bfwd->current_buffer, current_buffer); - valcontents = bfwd->current_value; } - break; + /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ + bfwd->current_alist_element = aelt; + /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */ + XSETBUFFER (bfwd->current_buffer, current_buffer); + valcontents = bfwd->current_value; } - default: - abort (); - } + break; + } + default: + abort (); } - store_symval_forwarding (sym, valcontents, newval); + store_symval_forwarding (symbol, valcontents, newval); return newval; } @@ -1858,7 +1843,7 @@ default_value (Lisp_Object sym) XCONSOLE (Vselected_console)); } - RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ + RETURN_NOT_REACHED (Qnil) /* suppress compiler warning */ } DEFUN ("default-boundp", Fdefault_boundp, 1, 1, 0, /* @@ -1866,9 +1851,9 @@ Return t if SYMBOL has a non-void default value. This is the value that is seen in buffers that do not have their own values for this variable. */ - (sym)) + (symbol)) { - return UNBOUNDP (default_value (sym)) ? Qnil : Qt; + return UNBOUNDP (default_value (symbol)) ? Qnil : Qt; } DEFUN ("default-value", Fdefault_value, 1, 1, 0, /* @@ -1877,11 +1862,11 @@ This is the value that is seen in buffers that do not have their own values for this variable. The default value is meaningful for variables with local bindings in certain buffers. */ - (sym)) + (symbol)) { - Lisp_Object value = default_value (sym); + Lisp_Object value = default_value (symbol); - return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (sym)) : value; + return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (symbol)) : value; } DEFUN ("set-default", Fset_default, 2, 2, 0, /* @@ -1889,39 +1874,39 @@ Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated. The default value is seen in buffers that do not have their own values for this variable. */ - (sym, value)) + (symbol, value)) { Lisp_Object valcontents; - CHECK_SYMBOL (sym); + CHECK_SYMBOL (symbol); retry: - valcontents = XSYMBOL (sym)->value; + valcontents = XSYMBOL (symbol)->value; retry_2: if (!SYMBOL_VALUE_MAGIC_P (valcontents)) - return Fset (sym, value); + return Fset (symbol, value); switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) { case SYMVAL_LISP_MAGIC: - RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (sym, Qset_default, 1, + RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (symbol, Qset_default, 1, value)); valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; /* semi-change-o */ goto retry_2; case SYMVAL_VARALIAS: - sym = follow_varalias_pointers (sym, Qset_default); + symbol = follow_varalias_pointers (symbol, Qset_default); /* presto change-o! */ goto retry; case SYMVAL_CURRENT_BUFFER_FORWARD: - set_default_buffer_slot_variable (sym, value); + set_default_buffer_slot_variable (symbol, value); return value; case SYMVAL_SELECTED_CONSOLE_FORWARD: - set_default_console_slot_variable (sym, value); + set_default_console_slot_variable (symbol, value); return value; case SYMVAL_BUFFER_LOCAL: @@ -1935,50 +1920,48 @@ for this variable. /* If current-buffer doesn't shadow default_value, * we must set the CURRENT-VALUE slot too */ if (NILP (bfwd->current_alist_element)) - store_symval_forwarding (sym, bfwd->current_value, value); + store_symval_forwarding (symbol, bfwd->current_value, value); return value; } default: - return Fset (sym, value); + return Fset (symbol, value); } - RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ } -DEFUN ("setq-default", Fsetq_default, 2, UNEVALLED, 0, /* -Set the default value of variable SYM to VALUE. -SYM, the variable name, is literal (not evaluated); +DEFUN ("setq-default", Fsetq_default, 0, UNEVALLED, 0, /* +Set the default value of variable SYMBOL to VALUE. +SYMBOL, the variable name, is literal (not evaluated); VALUE is an expression and it is evaluated. The default value of a variable is seen in buffers that do not have their own values for the variable. More generally, you can use multiple variables and values, as in - (setq-default SYM VALUE SYM VALUE...) -This sets each SYM's default value to the corresponding VALUE. -The VALUE for the Nth SYM can refer to the new default values -of previous SYMs. + (setq-default SYMBOL VALUE SYMBOL VALUE...) +This sets each SYMBOL's default value to the corresponding VALUE. +The VALUE for the Nth SYMBOL can refer to the new default values +of previous SYMBOLs. */ (args)) { /* This function can GC */ - Lisp_Object args_left; - Lisp_Object val, sym; + Lisp_Object symbol, tail, val = Qnil; + int nargs; struct gcpro gcpro1; - if (NILP (args)) - return Qnil; + GET_LIST_LENGTH (args, nargs); + + if (nargs & 1) /* Odd number of arguments? */ + Fsignal (Qwrong_number_of_arguments, + list2 (Qsetq_default, make_int (nargs))); - args_left = args; - GCPRO1 (args); + GCPRO1 (val); - do + PROPERTY_LIST_LOOP (tail, symbol, val, args) { - val = Feval (Fcar (Fcdr (args_left))); - sym = Fcar (args_left); - Fset_default (sym, val); - args_left = Fcdr (Fcdr (args_left)); + val = Feval (val); + Fset_default (symbol, val); } - while (!NILP (args_left)); UNGCPRO; return val; @@ -2379,7 +2362,7 @@ From now on the default value will apply in this console. Lisp_Object oldval = * (Lisp_Object *) (offset + (char *) XCONSOLE (Vconsole_defaults)); if (magicfun) - (magicfun) (variable, &oldval, Vselected_console, 0); + magicfun (variable, &oldval, Vselected_console, 0); *(Lisp_Object *) (offset + (char *) XCONSOLE (Vselected_console)) = oldval; XCONSOLE (Vselected_console)->local_var_flags &= ~mask; @@ -2390,7 +2373,6 @@ From now on the default value will apply in this console. default: return variable; } - RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ } /* Used by specbind to determine what effects it might have. Returns: @@ -2464,10 +2446,7 @@ Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound. CHECK_SYMBOL (symbol); CHECK_BUFFER (buffer); value = symbol_value_in_buffer (symbol, buffer); - if (UNBOUNDP (value)) - return unbound_value; - else - return value; + return UNBOUNDP (value) ? unbound_value : value; } DEFUN ("symbol-value-in-console", Fsymbol_value_in_console, 2, 3, 0, /* @@ -2479,14 +2458,11 @@ Return the value of SYMBOL in CONSOLE, or UNBOUND-VALUE if it is unbound. CHECK_SYMBOL (symbol); CHECK_CONSOLE (console); value = symbol_value_in_console (symbol, console); - if (UNBOUNDP (value)) - return unbound_value; - else - return value; + return UNBOUNDP (value) ? unbound_value : value; } DEFUN ("built-in-variable-type", Fbuilt_in_variable_type, 1, 1, 0, /* -If SYM is a built-in variable, return info about this; else return nil. +If SYMBOL is a built-in variable, return info about this; else return nil. The returned info will be a symbol, one of `object' A simple built-in variable. @@ -2505,85 +2481,56 @@ The returned info will be a symbol, one of `default-console' Forwards to the default value of a built-in console-local variable. */ - (sym)) + (symbol)) { REGISTER Lisp_Object valcontents; - CHECK_SYMBOL (sym); + CHECK_SYMBOL (symbol); retry: - valcontents = XSYMBOL (sym)->value; + valcontents = XSYMBOL (symbol)->value; + retry_2: + if (!SYMBOL_VALUE_MAGIC_P (valcontents)) + return Qnil; - if (SYMBOL_VALUE_MAGIC_P (valcontents)) + switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) { - switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) - { - case SYMVAL_LISP_MAGIC: - valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; - /* semi-change-o */ - goto retry_2; - - case SYMVAL_VARALIAS: - sym = follow_varalias_pointers (sym, Qt); - /* presto change-o! */ - goto retry; - - case SYMVAL_BUFFER_LOCAL: - case SYMVAL_SOME_BUFFER_LOCAL: - valcontents = - XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value; - /* semi-change-o */ - goto retry_2; - - case SYMVAL_FIXNUM_FORWARD: - return Qinteger; - - case SYMVAL_CONST_FIXNUM_FORWARD: - return Qconst_integer; - - case SYMVAL_BOOLEAN_FORWARD: - return Qboolean; - - case SYMVAL_CONST_BOOLEAN_FORWARD: - return Qconst_boolean; - - case SYMVAL_OBJECT_FORWARD: - return Qobject; - - case SYMVAL_CONST_OBJECT_FORWARD: - return Qconst_object; - - case SYMVAL_CONST_SPECIFIER_FORWARD: - return Qconst_specifier; - - case SYMVAL_DEFAULT_BUFFER_FORWARD: - return Qdefault_buffer; - - case SYMVAL_CURRENT_BUFFER_FORWARD: - return Qcurrent_buffer; - - case SYMVAL_CONST_CURRENT_BUFFER_FORWARD: - return Qconst_current_buffer; - - case SYMVAL_DEFAULT_CONSOLE_FORWARD: - return Qdefault_console; + case SYMVAL_LISP_MAGIC: + valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; + /* semi-change-o */ + goto retry_2; - case SYMVAL_SELECTED_CONSOLE_FORWARD: - return Qselected_console; + case SYMVAL_VARALIAS: + symbol = follow_varalias_pointers (symbol, Qt); + /* presto change-o! */ + goto retry; - case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: - return Qconst_selected_console; + case SYMVAL_BUFFER_LOCAL: + case SYMVAL_SOME_BUFFER_LOCAL: + valcontents = + XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value; + /* semi-change-o */ + goto retry_2; - case SYMVAL_UNBOUND_MARKER: - return Qnil; + case SYMVAL_FIXNUM_FORWARD: return Qinteger; + case SYMVAL_CONST_FIXNUM_FORWARD: return Qconst_integer; + case SYMVAL_BOOLEAN_FORWARD: return Qboolean; + case SYMVAL_CONST_BOOLEAN_FORWARD: return Qconst_boolean; + case SYMVAL_OBJECT_FORWARD: return Qobject; + case SYMVAL_CONST_OBJECT_FORWARD: return Qconst_object; + case SYMVAL_CONST_SPECIFIER_FORWARD: return Qconst_specifier; + case SYMVAL_DEFAULT_BUFFER_FORWARD: return Qdefault_buffer; + case SYMVAL_CURRENT_BUFFER_FORWARD: return Qcurrent_buffer; + case SYMVAL_CONST_CURRENT_BUFFER_FORWARD: return Qconst_current_buffer; + case SYMVAL_DEFAULT_CONSOLE_FORWARD: return Qdefault_console; + case SYMVAL_SELECTED_CONSOLE_FORWARD: return Qselected_console; + case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: return Qconst_selected_console; + case SYMVAL_UNBOUND_MARKER: return Qnil; - default: - abort (); - } + default: + abort (); return Qnil; } - - return Qnil; } @@ -2636,7 +2583,7 @@ The interface and/or function name is sure to change before this gets into its final form. I currently like the way everything is set up and it has all the features I want it to have, except for one: I really want to be able to have multiple nested handlers, -to implement an `advice'-like capabiility. This would allow, +to implement an `advice'-like capability. This would allow, for example, a clean way of implementing `debug-if-set' or `debug-if-referenced' and such. @@ -2945,7 +2892,7 @@ pity, thereby invalidating your code. /* functions for working with variable aliases. */ -/* Follow the chain of variable aliases for OBJECT. Return the +/* Follow the chain of variable aliases for SYMBOL. Return the resulting symbol, whose value cell is guaranteed not to be a symbol-value-varalias. @@ -2973,36 +2920,32 @@ pity, thereby invalidating your code. */ static Lisp_Object -follow_varalias_pointers (Lisp_Object object, +follow_varalias_pointers (Lisp_Object symbol, Lisp_Object follow_past_lisp_magic) { - Lisp_Object tortoise = object; - Lisp_Object hare = object; +#define VARALIAS_INDIRECTION_SUSPICION_LENGTH 16 + Lisp_Object tortoise, hare, val; + int count; /* quick out just in case */ - if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (object)->value)) - return object; - - /* based off of indirect_function() */ - for (;;) + if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (symbol)->value)) + return symbol; + + /* Compare implementation of indirect_function(). */ + for (hare = tortoise = symbol, count = 0; + val = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic), + SYMBOL_VALUE_VARALIAS_P (val); + hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (val)), + count++) { - Lisp_Object value; - - value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic); - if (!SYMBOL_VALUE_VARALIAS_P (value)) - break; - hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value)); - value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic); - if (!SYMBOL_VALUE_VARALIAS_P (value)) - break; - hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value)); - - value = fetch_value_maybe_past_magic (tortoise, follow_past_lisp_magic); - tortoise = symbol_value_varalias_aliasee - (XSYMBOL_VALUE_VARALIAS (value)); + if (count < VARALIAS_INDIRECTION_SUSPICION_LENGTH) continue; + if (count & 1) + tortoise = symbol_value_varalias_aliasee + (XSYMBOL_VALUE_VARALIAS (fetch_value_maybe_past_magic + (tortoise, follow_past_lisp_magic))); if (EQ (hare, tortoise)) - return Fsignal (Qcyclic_variable_indirection, list1 (object)); + return Fsignal (Qcyclic_variable_indirection, list1 (symbol)); } return hare; @@ -3147,13 +3090,13 @@ init_symbols_once_early (void) #ifndef Qnull_pointer /* C guarantees that Qnull_pointer will be initialized to all 0 bits, - so the following is a actually a no-op. */ + so the following is actually a no-op. */ XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0); #endif /* see comment in Fpurecopy() */ Vpure_uninterned_symbol_table = - make_lisp_hashtable (50, HASHTABLE_NONWEAK, HASHTABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); staticpro (&Vpure_uninterned_symbol_table); Qnil = Fmake_symbol (make_pure_pname ((CONST Bufbyte *) "nil", 3, 1)); @@ -3215,17 +3158,16 @@ defkeyword (Lisp_Object *location, CONST char *name) Fset (*location, *location); } -void -defsubr (struct Lisp_Subr *subr) -{ - Lisp_Object sym = intern (subr_name (subr)); - #ifdef DEBUG_XEMACS - /* Check that nobody spazzed writing a DEFUN. */ +/* Check that nobody spazzed writing a DEFUN. */ +static void +check_sane_subr (Lisp_Subr *subr, Lisp_Object sym) +{ assert (subr->min_args >= 0); assert (subr->min_args <= SUBR_MAX_ARGS); - if (subr->max_args != MANY && subr->max_args != UNEVALLED) + if (subr->max_args != MANY && + subr->max_args != UNEVALLED) { /* Need to fix lisp.h and eval.c if SUBR_MAX_ARGS too small */ assert (subr->max_args <= SUBR_MAX_ARGS); @@ -3233,9 +3175,34 @@ defsubr (struct Lisp_Subr *subr) } assert (UNBOUNDP (XSYMBOL (sym)->function)); -#endif /* DEBUG_XEMACS */ +} +#else +#define check_sane_subr(subr, sym) /* nothing */ +#endif + +void +defsubr (Lisp_Subr *subr) +{ + Lisp_Object sym = intern (subr_name (subr)); + Lisp_Object fun; + + check_sane_subr (subr, sym); + + XSETSUBR (fun, subr); + XSYMBOL (sym)->function = fun; +} + +/* Define a lisp macro using a Lisp_Subr. */ +void +defsubr_macro (Lisp_Subr *subr) +{ + Lisp_Object sym = intern (subr_name (subr)); + Lisp_Object fun; + + check_sane_subr (subr, sym); - XSETSUBR (XSYMBOL (sym)->function, subr); + XSETSUBR (fun, subr); + XSYMBOL (sym)->function = Fcons (Qmacro, fun); } void @@ -3275,6 +3242,7 @@ syms_of_symbols (void) defsymbol (&Qmakunbound, "makunbound"); defsymbol (&Qsymbol_value, "symbol-value"); defsymbol (&Qset, "set"); + defsymbol (&Qsetq_default, "setq-default"); defsymbol (&Qdefault_boundp, "default-boundp"); defsymbol (&Qdefault_value, "default-value"); defsymbol (&Qset_default, "set-default"); @@ -3313,6 +3281,7 @@ syms_of_symbols (void) DEFSUBR (Ffboundp); DEFSUBR (Ffset); DEFSUBR (Fdefine_function); + Ffset (intern ("defalias"), intern ("define-function")); DEFSUBR (Fsetplist); DEFSUBR (Fsymbol_value_in_buffer); DEFSUBR (Fsymbol_value_in_console); @@ -3334,29 +3303,29 @@ syms_of_symbols (void) DEFSUBR (Fdontusethis_set_symbol_value_handler); } -/* Create and initialize a variable whose value is forwarded to C data */ +/* Create and initialize a Lisp variable whose value is forwarded to C data */ void -defvar_mumble (CONST char *namestring, CONST void *magic, size_t sizeof_magic) +defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic) { - Lisp_Object kludge; - Lisp_Object sym = Fintern (make_pure_pname ((CONST Bufbyte *) namestring, - strlen (namestring), - 1), - Qnil); + Lisp_Object sym, kludge; - /* Check that magic points somewhere we can represent as a Lisp pointer */ + /* Check that `magic' points somewhere we can represent as a Lisp pointer */ XSETOBJ (kludge, Lisp_Type_Record, magic); - if (magic != (CONST void *) XPNTR (kludge)) + if ((void *)magic != (void*) XPNTR (kludge)) { /* This might happen on DATA_SEG_BITS machines. */ /* abort (); */ /* Copy it to somewhere which is representable. */ - void *f = xmalloc (sizeof_magic); - memcpy (f, magic, sizeof_magic); - XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, f); + struct symbol_value_forward *p = xnew (struct symbol_value_forward); + memcpy (p, magic, sizeof *magic); + magic = p; } - else - XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic); + + sym = Fintern (make_pure_pname ((CONST Bufbyte *) symbol_name, + strlen (symbol_name), + 1), + Qnil); + XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic); } void diff --git a/src/symeval.h b/src/symeval.h index fc4a3ad..effd36b 100644 --- a/src/symeval.h +++ b/src/symeval.h @@ -99,8 +99,9 @@ void print_symbol_value_magic (Lisp_Object, Lisp_Object, int); struct symbol_value_forward { struct symbol_value_magic magic; - /* void *forward; -- use magic.lcheader.next instead */ - /* Function controlling magic behavior of this forward variable. + + /* `magicfun' is a function controlling the magic behavior of this + forward variable. SYM is the symbol being operated on (read, set, etc.); @@ -122,20 +123,15 @@ struct symbol_value_forward that the only console-local variables currently existing are built-in ones, because others can't be created.) - FLAGS gives more information about the operation being - performed. + FLAGS gives more information about the operation being performed. - The return value indicates what the magic function actually - did. + The return value indicates what the magic function actually did. Currently FLAGS and the return value are not used. This function is only called when the value of a forward variable is about to be changed. Note that this can occur explicitly through a call to `set', `setq', `set-default', or `setq-default', - or implicitly by the current buffer being changed. - - */ - + or implicitly by the current buffer being changed. */ int (*magicfun) (Lisp_Object sym, Lisp_Object *val, Lisp_Object in_object, int flags); }; @@ -271,10 +267,19 @@ DECLARE_LRECORD (symbol_value_varalias, struct symbol_value_varalias); #define symbol_value_varalias_aliasee(m) ((m)->aliasee) #define symbol_value_varalias_shadowed(m) ((m)->shadowed) -/* DEFSUBR (Fname); - is how we define the symbol for function `Fname' at start-up time. */ +/* To define a Lisp primitive function using a C function `Fname', do this: + DEFUN ("name, Fname, ...); // at top level in foo.c + DEFSUBR (Fname); // in syms_of_foo(); +*/ +void defsubr (Lisp_Subr *); #define DEFSUBR(Fname) defsubr (&S##Fname) -void defsubr (struct Lisp_Subr *); + +/* To define a Lisp primitive macro using a C function `Fname', do this: + DEFUN ("name, Fname, ...); // at top level in foo.c + DEFSUBR_MACRO (Fname); // in syms_of_foo(); +*/ +void defsubr_macro (Lisp_Subr *); +#define DEFSUBR_MACRO(Fname) defsubr_macro (&S##Fname) void defsymbol (Lisp_Object *location, CONST char *name); @@ -286,7 +291,7 @@ void deferror (Lisp_Object *symbol, CONST char *name, /* Macros we use to define forwarded Lisp variables. These are used in the syms_of_FILENAME functions. */ -void defvar_mumble (CONST char *names, CONST void *magic, size_t sizeof_magic); +void defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION # define symbol_value_forward_lheader_initializer { 1, 0, 0 } @@ -295,44 +300,39 @@ void defvar_mumble (CONST char *names, CONST void *magic, size_t sizeof_magic); { lrecord_symbol_value_forward } #endif -#define DEFVAR_HEADER(lname, c_location, forward_type) \ - DEFVAR_MAGIC_HEADER (lname, c_location, forward_type, 0) - -#define DEFVAR_MAGIC_HEADER(lname, c_location, forward_type, magicfun) do { \ - static CONST struct symbol_value_forward I_hate_C \ +#define DEFVAR_SYMVAL_FWD(lname, c_location, forward_type, magicfun) do { \ + static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) (c_location), 69 }, \ + (struct lcrecord_header *) (c_location), 69 }, \ forward_type }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ + defvar_magic ((lname), &I_hate_C); \ } while (0) -#define DEFVAR_HEADER_GCPRO(lname, c_location, symbol_value_type) do { \ - DEFVAR_HEADER (lname, c_location, symbol_value_type); \ - staticpro (c_location); \ +#define DEFVAR_SYMVAL_FWD_OBJECT(lname, c_location, forward_type, magicfun) do{ \ + DEFVAR_SYMVAL_FWD (lname, c_location, forward_type, magicfun); \ + staticpro (c_location); \ + if (EQ (*c_location, Qnull_pointer)) *c_location = Qnil; \ } while (0) -#define DEFVAR_LISP(lname, c_location) \ - DEFVAR_HEADER_GCPRO (lname, c_location, SYMVAL_OBJECT_FORWARD) +#define DEFVAR_LISP(lname, c_location) \ + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_OBJECT_FORWARD, 0) #define DEFVAR_CONST_LISP(lname, c_location) \ - DEFVAR_HEADER_GCPRO (lname, c_location, SYMVAL_CONST_OBJECT_FORWARD) + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_CONST_OBJECT_FORWARD, 0) #define DEFVAR_SPECIFIER(lname, c_location) \ - DEFVAR_HEADER_GCPRO (lname, c_location, SYMVAL_CONST_SPECIFIER_FORWARD) + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_CONST_SPECIFIER_FORWARD, 0) #define DEFVAR_INT(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_FIXNUM_FORWARD) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_FIXNUM_FORWARD, 0) #define DEFVAR_CONST_INT(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_CONST_FIXNUM_FORWARD) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_CONST_FIXNUM_FORWARD, 0) #define DEFVAR_BOOL(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_BOOLEAN_FORWARD) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_BOOLEAN_FORWARD, 0) #define DEFVAR_CONST_BOOL(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_CONST_BOOLEAN_FORWARD) - -#define DEFVAR_LISP_MAGIC(lname, c_location, magicfun) do { \ - DEFVAR_MAGIC_HEADER (lname, c_location, SYMVAL_OBJECT_FORWARD, magicfun); \ - staticpro (c_location); \ -} while (0) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_CONST_BOOLEAN_FORWARD, 0) +#define DEFVAR_LISP_MAGIC(lname, c_location, magicfun) \ + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_OBJECT_FORWARD, magicfun); #define DEFVAR_INT_MAGIC(lname, c_location, magicfun) \ - DEFVAR_MAGIC_HEADER (lname, c_location, SYMVAL_FIXNUM_FORWARD, magicfun); + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_FIXNUM_FORWARD, magicfun); #define DEFVAR_BOOL_MAGIC(lname, c_location, magicfun) \ - DEFVAR_MAGIC_HEADER (lname, c_location, SYMVAL_BOOLEAN_FORWARD, magicfun); + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_BOOLEAN_FORWARD, magicfun); #endif /* _XEMACS_SYMEVAL_H_ */ diff --git a/src/symsinit.h b/src/symsinit.h index 1b0b8f2..4840c98 100644 --- a/src/symsinit.h +++ b/src/symsinit.h @@ -186,7 +186,7 @@ void structure_type_create (void); void structure_type_create_chartab (void); void structure_type_create_faces (void); void structure_type_create_rangetab (void); -void structure_type_create_hashtable (void); +void structure_type_create_hash_table (void); /* Initialize the image instantiator types (dump-time only). */ diff --git a/src/syntax.c b/src/syntax.c index 9a1d56b..33b396e 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -27,8 +27,6 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" #include "buffer.h" -#include "commands.h" -#include "insdel.h" #include "syntax.h" /* Here is a comment from Ken'ichi HANDA @@ -396,10 +394,12 @@ scan_words (struct buffer *buf, Bufpos from, int count) } DEFUN ("forward-word", Fforward_word, 1, 2, "_p", /* -Move point forward ARG words (backward if ARG is negative). +Move point forward COUNT words (backward if COUNT is negative). Normally returns t. If an edge of the buffer is reached, point is left there and nil is returned. + +Optional argument BUFFER defaults to the current buffer. */ (count, buffer)) { diff --git a/src/syntax.h b/src/syntax.h index 9b66c7a..e141eb0 100644 --- a/src/syntax.h +++ b/src/syntax.h @@ -89,8 +89,7 @@ INLINE int WORD_SYNTAX_P (struct Lisp_Char_Table *table, Emchar c); INLINE int WORD_SYNTAX_P (struct Lisp_Char_Table *table, Emchar c) { - int syncode = SYNTAX (table, c); - return syncode == Sword; + return SYNTAX (table, c) == Sword; } /* OK, here's a graphic diagram of the format of the syntax values: diff --git a/src/sysdep.c b/src/sysdep.c index c2b9800..9755327 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -212,11 +212,7 @@ set_descriptor_non_blocking (int fd) } #endif -#ifdef O_NONBLOCK /* The POSIX way */ fcntl (fd, F_SETFL, O_NONBLOCK); -#elif defined (O_NDELAY) - fcntl (fd, F_SETFL, O_NDELAY); -#endif /* O_NONBLOCK */ } #if defined (NO_SUBPROCESSES) @@ -456,8 +452,8 @@ child_setup_tty (int out) s.main.c_lflag |= ICANON; /* Enable erase/kill and eof processing */ s.main.c_cc[VEOF] = 04; /* ensure that EOF is Control-D */ - s.main.c_cc[VERASE] = CDISABLE; /* disable erase processing */ - s.main.c_cc[VKILL] = CDISABLE; /* disable kill processing */ + s.main.c_cc[VERASE] = _POSIX_VDISABLE; /* disable erase processing */ + s.main.c_cc[VKILL] = _POSIX_VDISABLE; /* disable kill processing */ #ifdef HPUX s.main.c_cflag = (s.main.c_cflag & ~CBAUD) | B9600; /* baud rate sanity */ @@ -485,12 +481,12 @@ child_setup_tty (int out) #else /* no TIOCGPGRP or no TIOCGLTC or no TIOCGETC */ /* TTY `special characters' work better as signals, so disable character forms */ - s.main.c_cc[VQUIT] = CDISABLE; - s.main.c_cc[VINTR] = CDISABLE; - s.main.c_cc[VSUSP] = CDISABLE; + s.main.c_cc[VQUIT] = _POSIX_VDISABLE; + s.main.c_cc[VINTR] = _POSIX_VDISABLE; + s.main.c_cc[VSUSP] = _POSIX_VDISABLE; s.main.c_lflag &= ~ISIG; #endif /* no TIOCGPGRP or no TIOCGLTC or no TIOCGETC */ - s.main.c_cc[VEOL] = CDISABLE; + s.main.c_cc[VEOL] = _POSIX_VDISABLE; #if defined (CBAUD) /* ### This is not portable. ### POSIX does not specify CBAUD, and 4.4BSD does not have it. @@ -749,7 +745,7 @@ get_eof_char (int fd) else return (Bufbyte) t.c_cc[VEOF]; #endif - return t.c_cc[VEOF] == CDISABLE ? ctrl_d : (Bufbyte) t.c_cc[VEOF]; + return t.c_cc[VEOF] == _POSIX_VDISABLE ? ctrl_d : (Bufbyte) t.c_cc[VEOF]; } #else /* ! HAVE_TERMIOS */ /* On Berkeley descendants, the following IOCTL's retrieve the @@ -1534,51 +1530,51 @@ tty_init_sys_modes_on_device (struct device *d) } else { - tty.main.c_cc[VINTR] = CDISABLE; - tty.main.c_cc[VQUIT] = CDISABLE; + tty.main.c_cc[VINTR] = _POSIX_VDISABLE; + tty.main.c_cc[VQUIT] = _POSIX_VDISABLE; } tty.main.c_cc[VMIN] = 1; /* Input should wait for at least 1 char */ tty.main.c_cc[VTIME] = 0; /* no matter how long that takes. */ #ifdef VSWTCH - tty.main.c_cc[VSWTCH] = CDISABLE; /* Turn off shell layering use - of C-z */ + tty.main.c_cc[VSWTCH] = _POSIX_VDISABLE; /* Turn off shell layering use + of C-z */ #endif /* VSWTCH */ /* There was some conditionalizing here on (mips or TCATTR), but I think that's wrong. There was one report of C-y (DSUSP) not being disabled on HP9000s700 systems, and this might fix it. */ #ifdef VSUSP - tty.main.c_cc[VSUSP] = CDISABLE;/* Turn off mips handling of C-z. */ + tty.main.c_cc[VSUSP] = _POSIX_VDISABLE; /* Turn off mips handling of C-z. */ #endif /* VSUSP */ #ifdef V_DSUSP - tty.main.c_cc[V_DSUSP] = CDISABLE; /* Turn off mips handling of C-y. */ + tty.main.c_cc[V_DSUSP] = _POSIX_VDISABLE; /* Turn off mips handling of C-y. */ #endif /* V_DSUSP */ #ifdef VDSUSP /* Some systems have VDSUSP, some have V_DSUSP. */ - tty.main.c_cc[VDSUSP] = CDISABLE; + tty.main.c_cc[VDSUSP] = _POSIX_VDISABLE; #endif /* VDSUSP */ #ifdef VLNEXT - tty.main.c_cc[VLNEXT] = CDISABLE; + tty.main.c_cc[VLNEXT] = _POSIX_VDISABLE; #endif /* VLNEXT */ #ifdef VREPRINT - tty.main.c_cc[VREPRINT] = CDISABLE; + tty.main.c_cc[VREPRINT] = _POSIX_VDISABLE; #endif /* VREPRINT */ #ifdef VWERASE - tty.main.c_cc[VWERASE] = CDISABLE; + tty.main.c_cc[VWERASE] = _POSIX_VDISABLE; #endif /* VWERASE */ #ifdef VDISCARD - tty.main.c_cc[VDISCARD] = CDISABLE; + tty.main.c_cc[VDISCARD] = _POSIX_VDISABLE; #endif /* VDISCARD */ #ifdef VSTART - tty.main.c_cc[VSTART] = CDISABLE; + tty.main.c_cc[VSTART] = _POSIX_VDISABLE; #endif /* VSTART */ #ifdef VSTRT - tty.main.c_cc[VSTRT] = CDISABLE; /* called VSTRT on some systems */ + tty.main.c_cc[VSTRT] = _POSIX_VDISABLE; /* called VSTRT on some systems */ #endif /* VSTART */ #ifdef VSTOP - tty.main.c_cc[VSTOP] = CDISABLE; + tty.main.c_cc[VSTOP] = _POSIX_VDISABLE; #endif /* VSTOP */ #ifdef SET_LINE_DISCIPLINE - /* Need to explicitely request TERMIODISC line discipline or + /* Need to explicitly request TERMIODISC line discipline or Ultrix's termios does not work correctly. */ tty.main.c_line = SET_LINE_DISCIPLINE; #endif @@ -2072,7 +2068,6 @@ hft_reset (struct console *con) /* limits of text/data segments */ /************************************************************************/ -/* Note that VMS compiler won't accept defined (CANNOT_DUMP). */ #ifndef CANNOT_DUMP #define NEED_STARTS #endif @@ -2137,7 +2132,7 @@ start_of_text (void) * at least on UniPlus, is temacs will have to be made unshared so * that text and data are contiguous. Then once loadup is complete, * unexec will produce a shared executable where the data can be - * at the normal shared text boundry and the startofdata variable + * at the normal shared text boundary and the startofdata variable * will be patched by unexec to the correct value. * */ @@ -2594,7 +2589,8 @@ sys_open (CONST char *path, int oflag, ...) { int rtnval; while ((rtnval = open (path, oflag, mode)) == -1 - && (errno == EINTR)); + && (errno == EINTR)) + DO_NOTHING; return rtnval; } #else @@ -2779,7 +2775,8 @@ sys_fopen (CONST char *path, CONST char *type) #elif defined (INTERRUPTIBLE_OPEN) { FILE *rtnval; - while (!(rtnval = fopen (path, type)) && (errno == EINTR)); + while (!(rtnval = fopen (path, type)) && (errno == EINTR)) + DO_NOTHING; return rtnval; } #else @@ -3682,7 +3679,7 @@ opendir (CONST char *filename) /* name of directory */ int fd; /* file descriptor for read */ struct stat sbuf; /* result of fstat */ - fd = sys_open (filename, 0); + fd = sys_open (filename, O_RDONLY); if (fd < 0) return 0; @@ -3799,24 +3796,24 @@ mkdir (CONST char *dpath, int dmode) { case -1: /* Error in fork() */ - return (-1); /* Errno is set already */ + return -1; /* Errno is set already */ case 0: /* Child process */ { /* - * Cheap hack to set mode of new directory. Since this - * child process is going away anyway, we zap its umask. - * ####, this won't suffice to set SUID, SGID, etc. on this - * directory. Does anybody care? - */ + * Cheap hack to set mode of new directory. Since this + * child process is going away anyway, we zap its umask. + * ####, this won't suffice to set SUID, SGID, etc. on this + * directory. Does anybody care? + */ status = umask (0); /* Get current umask */ status = umask (status | (0777 & ~dmode)); /* Set for mkdir */ - fd = sys_open ("/dev/null", 2); + fd = sys_open ("/dev/null", O_RDWR); if (fd >= 0) { - dup2 (fd, 0); - dup2 (fd, 1); - dup2 (fd, 2); + if (fd != STDIN_FILENO) dup2 (fd, STDIN_FILENO); + if (fd != STDOUT_FILENO) dup2 (fd, STDOUT_FILENO); + if (fd != STDERR_FILENO) dup2 (fd, STDERR_FILENO); } execl ("/bin/mkdir", "mkdir", dpath, (char *) 0); _exit (-1); /* Can't exec /bin/mkdir */ @@ -3857,12 +3854,12 @@ rmdir (CONST char *dpath) return (-1); /* Errno is set already */ case 0: /* Child process */ - fd = sys_open("/dev/null", 2); + fd = sys_open("/dev/null", O_RDWR); if (fd >= 0) { - dup2 (fd, 0); - dup2 (fd, 1); - dup2 (fd, 2); + if (fd != STDIN_FILENO) dup2 (fd, STDIN_FILENO); + if (fd != STDOUT_FILENO) dup2 (fd, STDOUT_FILENO); + if (fd != STDERR_FILENO) dup2 (fd, STDERR_FILENO); } execl ("/bin/rmdir", "rmdir", dpath, (char *) 0); _exit (-1); /* Can't exec /bin/mkdir */ @@ -3871,7 +3868,8 @@ rmdir (CONST char *dpath) wait_for_termination (cpid); } - if (synch_process_death != 0 || synch_process_retcode != 0) + if (synch_process_death != 0 || + synch_process_retcode != 0) { errno = EIO; /* We don't know why, but */ return -1; /* /bin/rmdir failed */ diff --git a/src/sysdep.h b/src/sysdep.h index 8b50a1f..79e6a76 100644 --- a/src/sysdep.h +++ b/src/sysdep.h @@ -59,7 +59,7 @@ void child_setup_tty (int out); /* Suspend the Emacs process; give terminal to its superior. */ void sys_suspend (void); -/* Suspend a process if possible; give termianl to its superior. */ +/* Suspend a process if possible; give terminal to its superior. */ void sys_suspend_process (int process); void request_sigio (void); diff --git a/src/sysdll.c b/src/sysdll.c index d5f309c..f339873 100644 --- a/src/sysdll.c +++ b/src/sysdll.c @@ -23,10 +23,6 @@ Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA #include #endif -#include -#include -#include -#include #include "sysdll.h" /* This whole file is conditional upon HAVE_DLL */ diff --git a/src/sysfile.h b/src/sysfile.h index 1a61127..3f4a694 100644 --- a/src/sysfile.h +++ b/src/sysfile.h @@ -55,6 +55,12 @@ Boston, MA 02111-1307, USA. */ #include #endif +#ifndef STDERR_FILENO +#define STDIN_FILENO 0 +#define STDOUT_FILENO 1 +#define STDERR_FILENO 2 +#endif + #ifndef O_RDONLY #define O_RDONLY 0 #endif @@ -116,6 +122,14 @@ Boston, MA 02111-1307, USA. */ #endif #endif +#ifndef O_NONBLOCK +#ifdef O_NDELAY +#define O_NONBLOCK O_NDELAY +#else +#define O_NONBLOCK 04000 +#endif +#endif + /* if system does not have symbolic links, it does not have lstat. In that case, use ordinary stat instead. */ diff --git a/src/sysproc.h b/src/sysproc.h index 8506f35..399f6c8 100644 --- a/src/sysproc.h +++ b/src/sysproc.h @@ -96,11 +96,6 @@ Boston, MA 02111-1307, USA. */ #endif /* no FD_SET */ -#ifdef EMACS_BTL -int cadillac_stop_logging (); -int cadillac_start_logging (); -#endif - int poll_fds_for_input (SELECT_TYPE mask); #ifdef MSDOS diff --git a/src/syssignal.h b/src/syssignal.h index d04b378..1332f39 100644 --- a/src/syssignal.h +++ b/src/syssignal.h @@ -112,30 +112,30 @@ signal_handler_t sys_do_signal (int signal_number, signal_handler_t action); #define EMACS_BLOCK_SIGNAL(sig) do \ { \ - sigset_t _mask; \ - sigemptyset (&_mask); \ - sigaddset (&_mask, sig); \ - sigprocmask (SIG_BLOCK, &_mask, NULL); \ + sigset_t ES_mask; \ + sigemptyset (&ES_mask); \ + sigaddset (&ES_mask, sig); \ + sigprocmask (SIG_BLOCK, &ES_mask, NULL); \ } while (0) #define EMACS_UNBLOCK_SIGNAL(sig) do \ { \ - sigset_t _mask; \ - sigemptyset (&_mask); \ - sigaddset (&_mask, sig); \ - sigprocmask (SIG_UNBLOCK, &_mask, NULL); \ + sigset_t ES_mask; \ + sigemptyset (&ES_mask); \ + sigaddset (&ES_mask, sig); \ + sigprocmask (SIG_UNBLOCK, &ES_mask, NULL); \ } while (0) #define EMACS_UNBLOCK_ALL_SIGNALS() do \ { \ - sigset_t _mask; \ - sigemptyset (&_mask); \ - sigprocmask (SIG_SETMASK, &_mask, NULL); \ + sigset_t ES_mask; \ + sigemptyset (&ES_mask); \ + sigprocmask (SIG_SETMASK, &ES_mask, NULL); \ } while (0) #define EMACS_WAIT_FOR_SIGNAL(sig) do \ { \ - sigset_t _mask; \ - sigprocmask (0, NULL, &_mask); \ - sigdelset (&_mask, sig); \ - sigsuspend (&_mask); \ + sigset_t ES_mask; \ + sigprocmask (0, NULL, &ES_mask); \ + sigdelset (&ES_mask, sig); \ + sigsuspend (&ES_mask); \ } while (0) #define EMACS_REESTABLISH_SIGNAL(sig, handler) @@ -159,8 +159,8 @@ signal_handler_t sys_do_signal (int signal_number, signal_handler_t action); #define EMACS_UNBLOCK_ALL_SIGNALS() sigsetmask (0) #define EMACS_WAIT_FOR_SIGNAL(sig) do \ { \ - int _mask = sigblock (0); \ - sigpause (_mask & ~sigmask (sig)); \ + int ES_mask = sigblock (0); \ + sigpause (ES_mask & ~sigmask (sig)); \ } while (0) #define EMACS_REESTABLISH_SIGNAL(sig, handler) diff --git a/src/systty.h b/src/systty.h index bceec58..7251557 100644 --- a/src/systty.h +++ b/src/systty.h @@ -53,6 +53,10 @@ Boston, MA 02111-1307, USA. */ /* Include the proper files. */ +#ifdef HAVE_UNISTD_H +#include +#endif + /* XEmacs: TERMIOS is mo' better than TERMIO so we use it if it's there. Since TERMIO is backward-compatibility stuff if both it and TERMIOS exist, it's more likely to be broken. */ @@ -193,10 +197,6 @@ Boston, MA 02111-1307, USA. */ #undef TIOCSWINSZ #endif -#ifdef BROKEN_O_NONBLOCK /* XEmacs addition */ -# undef O_NONBLOCK -#endif /* BROKEN_O_NONBLOCK */ - /* On TERMIOS systems, the tcmumbleattr calls take care of these parameters, and it's a bad idea to use them (on AIX, it makes the tty hang for a long time). */ @@ -214,19 +214,16 @@ Boston, MA 02111-1307, USA. */ /* ----------------------------------------------------- */ /* Try to establish the correct character to disable terminal functions - in a system-independent manner. Note that USG (at least) define - _POSIX_VDISABLE as 0! */ - -#ifdef _POSIX_VDISABLE -#define CDISABLE _POSIX_VDISABLE -#else /* not _POSIX_VDISABLE */ -#ifdef CDEL -#undef CDISABLE -#define CDISABLE CDEL -#else /* not CDEL */ -#define CDISABLE 255 -#endif /* not CDEL */ -#endif /* not _POSIX_VDISABLE */ + in a system-independent manner. + We use the POSIX standard way to do this, and emulate on other systems. */ + +#ifndef _POSIX_VDISABLE +# if defined CDEL +# define _POSIX_VDISABLE CDEL +# else +# define _POSIX_VDISABLE 255 +# endif +#endif /* ! _POSIX_VDISABLE */ /* ----------------------------------------------------- */ diff --git a/src/toolbar-msw.c b/src/toolbar-msw.c index b9fa959..1f978cc 100644 --- a/src/toolbar-msw.c +++ b/src/toolbar-msw.c @@ -87,7 +87,7 @@ allocate_toolbar_item_id (struct frame* f, struct toolbar_button* button, /* hmm what do we generate an id based on */ int id = TOOLBAR_ITEM_ID_BITS (internal_hash (button->callback, 0)); while (!NILP (Fgethash (make_int (id), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f), Qnil))) + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f), Qnil))) { id = TOOLBAR_ITEM_ID_BITS (id + 1); } @@ -105,14 +105,14 @@ mswindows_clear_toolbar (struct frame *f, enum toolbar_pos pos, { TBBUTTON info; - /* delete the buttons and remove the command from the hashtable*/ + /* Delete the buttons and remove the command from the hash table*/ i = SendMessage (toolbarwnd, TB_BUTTONCOUNT, 0, 0); for (i--; i >= 0; i--) { SendMessage (toolbarwnd, TB_GETBUTTON, (WPARAM)i, (LPARAM)&info); Fremhash(make_int(info.idCommand), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE(f)); + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f)); SendMessage (toolbarwnd, TB_DELETEBUTTON, (WPARAM)i, 0); } @@ -262,7 +262,7 @@ mswindows_output_toolbar (struct frame *f, enum toolbar_pos pos) if (IMAGE_INSTANCE_PIXMAP_TYPE_P (p)) { - /* we are going to honour the toolbar settings + /* we are going to honor the toolbar settings and resize the bitmaps accordingly if they are too big. If they are too small we leave them and pad the difference - unless a different size @@ -293,7 +293,7 @@ mswindows_output_toolbar (struct frame *f, enum toolbar_pos pos) { xfree (button_tbl); if (ilist) ImageList_Destroy (ilist); - signal_simple_error ("couldn't resize pixmap", + signal_simple_error ("Couldn't resize pixmap", instance); } /* we don't care if the mask fails */ @@ -316,7 +316,7 @@ mswindows_output_toolbar (struct frame *f, enum toolbar_pos pos) nbuttons, nbuttons * 2 ))) { xfree (button_tbl); - signal_simple_error ("couldn't create image list", + signal_simple_error ("Couldn't create image list", instance); } @@ -343,7 +343,7 @@ mswindows_output_toolbar (struct frame *f, enum toolbar_pos pos) } Fputhash (make_int (tbbutton->idCommand), - button, FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f)); + button, FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f)); } /* now fix up the button size */ @@ -582,7 +582,7 @@ Lisp_Object mswindows_get_toolbar_button_text ( struct frame* f, int command_id ) { Lisp_Object button = Fgethash (make_int (command_id), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f), Qnil); + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f), Qnil); if (!NILP (button)) { @@ -605,7 +605,7 @@ mswindows_handle_toolbar_wm_command (struct frame* f, HWND ctrl, WORD id) Lisp_Object button, data, fn, arg, frame; button = Fgethash (make_int (id), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f), Qnil); + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f), Qnil); if (NILP (button)) return Qnil; diff --git a/src/toolbar-x.c b/src/toolbar-x.c index 40c2f02..735d63c 100644 --- a/src/toolbar-x.c +++ b/src/toolbar-x.c @@ -29,10 +29,8 @@ Boston, MA 02111-1307, USA. */ #include "console-x.h" #include "glyphs-x.h" #include "objects-x.h" -#include "xgccache.h" #include "EmacsFrame.h" #include "EmacsFrameP.h" -#include "EmacsManager.h" #include "faces.h" #include "frame.h" diff --git a/src/toolbar.c b/src/toolbar.c index d45beca..1fbb435 100644 --- a/src/toolbar.c +++ b/src/toolbar.c @@ -59,17 +59,17 @@ Lisp_Object Qinit_toolbar_from_resources; static Lisp_Object mark_toolbar_button (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct toolbar_button *data = (struct toolbar_button *) XPNTR (obj); - ((markobj) (data->next)); - ((markobj) (data->frame)); - ((markobj) (data->up_glyph)); - ((markobj) (data->down_glyph)); - ((markobj) (data->disabled_glyph)); - ((markobj) (data->cap_up_glyph)); - ((markobj) (data->cap_down_glyph)); - ((markobj) (data->cap_disabled_glyph)); - ((markobj) (data->callback)); - ((markobj) (data->enabled_p)); + struct toolbar_button *data = XTOOLBAR_BUTTON (obj); + markobj (data->next); + markobj (data->frame); + markobj (data->up_glyph); + markobj (data->down_glyph); + markobj (data->disabled_glyph); + markobj (data->cap_up_glyph); + markobj (data->cap_down_glyph); + markobj (data->cap_disabled_glyph); + markobj (data->callback); + markobj (data->enabled_p); return data->help_string; } @@ -741,10 +741,10 @@ update_frame_toolbars (struct frame *f) /* We're not officially "in redisplay", so we still have a chance to re-layout toolbars and windows. This is done here, because toolbar is the only thing which currently might - necesseritate this layout, as it is outside any windows. We + necessitate this layout, as it is outside any windows. We take care not to change size if toolbar geometry is really unchanged, as it will hose windows whose pixsizes are not - multiple of character sizes */ + multiple of character sizes. */ for (pos = 0; pos < 4; pos++) if (FRAME_REAL_TOOLBAR_SIZE (f, pos) @@ -894,30 +894,27 @@ get_toolbar_coords (struct frame *f, enum toolbar_pos pos, int *x, int *y, } } -#define CHECK_TOOLBAR(pos) \ - do \ +#define CHECK_TOOLBAR(pos) do { \ + if (FRAME_REAL_##pos##_VISIBLE (f)) \ { \ + int x, y, width, height, vert; \ + \ get_toolbar_coords (f, pos, &x, &y, &width, &height, &vert, 0); \ if ((x_coord >= x) && (x_coord < (x + width))) \ { \ if ((y_coord >= y) && (y_coord < (y + height))) \ return FRAME_TOOLBAR_BUTTONS (f, pos); \ } \ - } while (0) + } \ +} while (0) static Lisp_Object toolbar_buttons_at_pixpos (struct frame *f, int x_coord, int y_coord) { - int x, y, width, height, vert; - - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (TOP_TOOLBAR); - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (BOTTOM_TOOLBAR); - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (LEFT_TOOLBAR); - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (RIGHT_TOOLBAR); + CHECK_TOOLBAR (TOP_TOOLBAR); + CHECK_TOOLBAR (BOTTOM_TOOLBAR); + CHECK_TOOLBAR (LEFT_TOOLBAR); + CHECK_TOOLBAR (RIGHT_TOOLBAR); return Qnil; } @@ -931,9 +928,6 @@ toolbar_button_at_pixpos (struct frame *f, int x_coord, int y_coord) { Lisp_Object buttons = toolbar_buttons_at_pixpos (f, x_coord, y_coord); - if (NILP (buttons)) - return Qnil; - while (!NILP (buttons)) { struct toolbar_button *tb = XTOOLBAR_BUTTON (buttons); @@ -953,7 +947,7 @@ toolbar_button_at_pixpos (struct frame *f, int x_coord, int y_coord) buttons = tb->next; } - /* We must be over a blank in the toolbar. */ + /* We are not over a toolbar or we are over a blank in the toolbar. */ return Qnil; } @@ -964,13 +958,10 @@ toolbar_button_at_pixpos (struct frame *f, int x_coord, int y_coord) DEFINE_SPECIFIER_TYPE (toolbar); -#define CTB_ERROR(msg) \ - do \ - { \ - maybe_signal_simple_error (msg, button, Qtoolbar, errb); \ - RETURN__ Qnil; \ - } \ - while (0) +#define CTB_ERROR(msg) do { \ + maybe_signal_simple_error (msg, button, Qtoolbar, errb); \ + RETURN_SANS_WARNINGS Qnil; \ +} while (0) /* Returns Q_style if key was :style, Qt if ok otherwise, Qnil if error. */ static Lisp_Object @@ -979,7 +970,7 @@ check_toolbar_button_keywords (Lisp_Object button, Lisp_Object key, { if (!KEYWORDP (key)) { - maybe_signal_simple_error_2 ("not a keyword", key, button, Qtoolbar, + maybe_signal_simple_error_2 ("Not a keyword", key, button, Qtoolbar, errb); return Qnil; } @@ -990,7 +981,7 @@ check_toolbar_button_keywords (Lisp_Object button, Lisp_Object key, && !EQ (val, Q3D) && !EQ (val, Q2d) && !EQ (val, Q3d)) - CTB_ERROR ("unrecognized toolbar blank style"); + CTB_ERROR ("Unrecognized toolbar blank style"); return Q_style; } @@ -1139,18 +1130,18 @@ toolbar_validate (Lisp_Object instantiator) return; if (!CONSP (instantiator)) - signal_simple_error ("toolbar spec must be list or nil", instantiator); + signal_simple_error ("Toolbar spec must be list or nil", instantiator); for (rest = instantiator; !NILP (rest); rest = XCDR (rest)) { if (!CONSP (rest)) - signal_simple_error ("bad list in toolbar spec", instantiator); + signal_simple_error ("Bad list in toolbar spec", instantiator); if (NILP (XCAR (rest))) { if (pushright_seen) error - ("more than one partition (nil) in instantiator description"); + ("More than one partition (nil) in instantiator description"); else pushright_seen = 1; } @@ -1200,7 +1191,7 @@ toolbar_specs_changed (Lisp_Object specifier, struct window *w, Lisp_Object oldval) { /* This could be smarter but I doubt that it would make any - noticable difference given the infrequency with which this is + noticeable difference given the infrequency with which this is probably going to be called. */ MARK_TOOLBAR_CHANGED; @@ -1272,7 +1263,7 @@ toolbar_buttons_captioned_p_changed (Lisp_Object specifier, struct window *w, Lisp_Object oldval) { /* This could be smarter but I doubt that it would make any - noticable difference given the infrequency with which this is + noticeable difference given the infrequency with which this is probably going to be called. */ MARK_TOOLBAR_CHANGED; } diff --git a/src/toolbar.h b/src/toolbar.h index 3bff80a..543ed2c 100644 --- a/src/toolbar.h +++ b/src/toolbar.h @@ -25,10 +25,10 @@ Boston, MA 02111-1307, USA. */ #ifndef _XEMACS_TOOLBAR_H_ #define _XEMACS_TOOLBAR_H_ -#include "specifier.h" - #ifdef HAVE_TOOLBARS +#include "specifier.h" + #define FRAME_TOOLBAR_BUTTONS(frame, pos) \ ((frame)->toolbar_buttons[pos]) #define FRAME_CURRENT_TOOLBAR_SIZE(frame, pos) \ @@ -65,7 +65,7 @@ struct toolbar_button int dirty; /* is this button in a left or right toolbar? */ int vertical; - /* border_width when this button was layed out */ + /* border_width when this button was laid out */ int border_width; }; diff --git a/src/tooltalk.c b/src/tooltalk.c index 260ab20..ac76e22 100644 --- a/src/tooltalk.c +++ b/src/tooltalk.c @@ -153,7 +153,7 @@ struct Lisp_Tooltalk_Message static Lisp_Object mark_tooltalk_message (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - (markobj) (XTOOLTALK_MESSAGE (obj)->callback); + markobj (XTOOLTALK_MESSAGE (obj)->callback); return XTOOLTALK_MESSAGE (obj)->plist_sym; } @@ -169,7 +169,7 @@ print_tooltalk_message (Lisp_Object obj, Lisp_Object printcharfun, error ("printing unreadable object #", p->header.uid); - sprintf (buf, "#", p->m, p->header.uid); + sprintf (buf, "#", (long) (p->m), p->header.uid); write_c_string (buf, printcharfun); } @@ -227,7 +227,7 @@ struct Lisp_Tooltalk_Pattern static Lisp_Object mark_tooltalk_pattern (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - (markobj) (XTOOLTALK_PATTERN (obj)->callback); + markobj (XTOOLTALK_PATTERN (obj)->callback); return XTOOLTALK_PATTERN (obj)->plist_sym; } @@ -243,7 +243,7 @@ print_tooltalk_pattern (Lisp_Object obj, Lisp_Object printcharfun, error ("printing unreadable object #", p->header.uid); - sprintf (buf, "#", p->p, p->header.uid); + sprintf (buf, "#", (long) (p->p), p->header.uid); write_c_string (buf, printcharfun); } @@ -673,7 +673,7 @@ value returned by 'arg_bval like a string is fine. (XTOOLTALK_MESSAGE (message_)->plist_sym)); else - signal_simple_error ("invalid value for `get-tooltalk-message-attribute'", + signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'", attribute); return Qnil; @@ -834,7 +834,7 @@ New arguments can be added to a message with add-tooltalk-message-arg. return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value); } else - signal_simple_error ("invalid value for `set-tooltalk-message-attribute'", + signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'", attribute); return Qnil; } @@ -1474,8 +1474,8 @@ Unprocessed messages are messages that didn't match any patterns. staticpro (&Vtooltalk_message_gcpro); staticpro (&Vtooltalk_pattern_gcpro); - Vtooltalk_message_gcpro = make_lisp_hashtable (10, HASHTABLE_NONWEAK, - HASHTABLE_EQ); - Vtooltalk_pattern_gcpro = make_lisp_hashtable (10, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + Vtooltalk_message_gcpro = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + Vtooltalk_pattern_gcpro = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); } diff --git a/src/tooltalk.doc b/src/tooltalk.doc index 69c8e9d..247bb8d 100644 --- a/src/tooltalk.doc +++ b/src/tooltalk.doc @@ -203,7 +203,7 @@ embedded nulls (use 'arg_bval). (create-tooltalk-message) Create a new tooltalk message. The messages session attribute is -initialized to the default session. Other attributes can be intialized +initialized to the default session. Other attributes can be initialized with set-tooltalk-message-attribute. Make-tooltalk-message is the preferred to create and initialize a message. @@ -211,7 +211,7 @@ preferred to create and initialize a message. (destroy-tooltalk-message msg) Apply tt_message_destroy to the message. It's not necessary -to destroy messages after they've been proccessed by a message or +to destroy messages after they've been processed by a message or pattern callback, the Lisp/Tooltalk callback machinery does this for you. diff --git a/src/unexcw.c b/src/unexcw.c index 09ab994..6d65e61 100644 --- a/src/unexcw.c +++ b/src/unexcw.c @@ -245,7 +245,7 @@ copy_executable_and_dump_data_section (int a_out, int a_new) void* empty_space; extern int static_heap_dumped; SCNHDR section; - /* calculate new sizes f_ohdr.dsize is the total initalized data + /* calculate new sizes f_ohdr.dsize is the total initialized data size on disk which is f_data.s_size + f_idata.s_size. f_ohdr.data_start is the base addres of all data and so should not be changed. *.s_vaddr is the virtual address of the start diff --git a/src/unexec.c b/src/unexec.c index 14ed085..06bb930 100644 --- a/src/unexec.c +++ b/src/unexec.c @@ -194,6 +194,7 @@ pointer looks like an int) but not on all machines. # include # include # include +# include # ifdef __lucid # include @@ -288,7 +289,7 @@ static long data_scnptr; #ifdef __STDC__ #ifndef __sys_stdtypes_h -#ifndef _PTRDIFF_T +#if !defined(_PTRDIFF_T) && !defined(_BSD_PTRDIFF_T_) typedef long ptrdiff_t; #endif #endif @@ -968,7 +969,7 @@ copy_text_and_data (int new, int a_out) #ifdef RISCiX - /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. + /* Acorn's RISC-iX has a wacky way of initializing the position of the heap. * There is a little table in crt0.o that is filled at link time with * the min and current brk positions, among other things. When start * runs, it copies the table to where these parameters live during diff --git a/src/widget.c b/src/widget.c index 129d07d..7a3a9e6 100644 --- a/src/widget.c +++ b/src/widget.c @@ -29,7 +29,6 @@ Boston, MA 02111-1307, USA. */ #include #include "lisp.h" #include "buffer.h" -#include "insdel.h" Lisp_Object Qwidget_type; @@ -52,7 +51,7 @@ Like `plist-get', but returns the tail of PLIST whose car is PROP. DEFUN ("widget-put", Fwidget_put, 3, 3, 0, /* In WIDGET set PROPERTY to VALUE. -The value can later be retrived with `widget-get'. +The value can later be retrieved with `widget-get'. */ (widget, property, value)) { @@ -68,12 +67,11 @@ later with `widget-put'. */ (widget, property)) { - Lisp_Object tmp, value; + Lisp_Object value = Qnil; - value = Qnil; while (1) { - tmp = Fwidget_plist_member (Fcdr (widget), property); + Lisp_Object tmp = Fwidget_plist_member (Fcdr (widget), property); if (!NILP (tmp)) { value = Fcar (Fcdr (tmp)); diff --git a/src/window.c b/src/window.c index 26193ca..db9f884 100644 --- a/src/window.c +++ b/src/window.c @@ -36,7 +36,6 @@ Boston, MA 02111-1307, USA. */ #include "glyphs.h" #include "redisplay.h" #include "window.h" -#include "commands.h" Lisp_Object Qwindowp, Qwindow_live_p, Qwindow_configurationp; Lisp_Object Qscroll_up, Qscroll_down, Qdisplay_buffer; @@ -136,36 +135,36 @@ do { \ #define MARK_DISP_VARIABLE(field) \ - ((markobj) (window->field[CURRENT_DISP])); \ - ((markobj) (window->field[DESIRED_DISP])); \ - ((markobj) (window->field[CMOTION_DISP])); + markobj (window->field[CURRENT_DISP]); \ + markobj (window->field[DESIRED_DISP]); \ + markobj (window->field[CMOTION_DISP]); static Lisp_Object mark_window (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct window *window = XWINDOW (obj); - ((markobj) (window->frame)); - ((markobj) (window->mini_p)); - ((markobj) (window->next)); - ((markobj) (window->prev)); - ((markobj) (window->hchild)); - ((markobj) (window->vchild)); - ((markobj) (window->parent)); - ((markobj) (window->buffer)); + markobj (window->frame); + markobj (window->mini_p); + markobj (window->next); + markobj (window->prev); + markobj (window->hchild); + markobj (window->vchild); + markobj (window->parent); + markobj (window->buffer); MARK_DISP_VARIABLE (start); MARK_DISP_VARIABLE (pointm); - ((markobj) (window->sb_point)); /* #### move to scrollbar.c? */ - ((markobj) (window->use_time)); + markobj (window->sb_point); /* #### move to scrollbar.c? */ + markobj (window->use_time); MARK_DISP_VARIABLE (last_modified); MARK_DISP_VARIABLE (last_point); MARK_DISP_VARIABLE (last_start); MARK_DISP_VARIABLE (last_facechange); - ((markobj) (window->line_cache_last_updated)); - ((markobj) (window->redisplay_end_trigger)); + markobj (window->line_cache_last_updated); + markobj (window->redisplay_end_trigger); mark_face_cachels (window->face_cachels, markobj); mark_glyph_cachels (window->glyph_cachels, markobj); -#define WINDOW_SLOT(slot, compare) ((markobj) (window->slot)) +#define WINDOW_SLOT(slot, compare) ((void) (markobj (window->slot))) #include "winslots.h" return Qnil; @@ -385,23 +384,21 @@ static Lisp_Object real_window_internal (Lisp_Object win, struct window_mirror *rmir, struct window_mirror *mir) { - Lisp_Object retval; - for (; !NILP (win) && rmir ; win = XWINDOW (win)->next, rmir = rmir->next) { if (mir == rmir) return win; if (!NILP (XWINDOW (win)->vchild)) { - retval = real_window_internal (XWINDOW (win)->vchild, rmir->vchild, - mir); + Lisp_Object retval = + real_window_internal (XWINDOW (win)->vchild, rmir->vchild, mir); if (!NILP (retval)) return retval; } if (!NILP (XWINDOW (win)->hchild)) { - retval = real_window_internal (XWINDOW (win)->hchild, rmir->hchild, - mir); + Lisp_Object retval = + real_window_internal (XWINDOW (win)->hchild, rmir->hchild, mir); if (!NILP (retval)) return retval; } @@ -746,7 +743,7 @@ window_needs_vertical_divider_1 (struct window *w) return 1; #ifdef HAVE_SCROLLBARS - /* Our right scrollabr is enough to separate us at the right */ + /* Our right scrollbar is enough to separate us at the right */ if (NILP (w->scrollbar_on_left_p) && !NILP (w->vertical_scrollbar_visible_p) && !ZEROP (w->scrollbar_width)) @@ -785,7 +782,7 @@ invalidate_vertical_divider_cache_in_window (struct window *w, /* Calculate width of vertical divider, including its shadows and spacing. The returned value is effectively the distance between adjacent window edges. This function does not check - whether a windows needs vertival divider, so the returned + whether a window needs a vertical divider, so the returned value is a "theoretical" one */ int window_divider_width (struct window *w) @@ -794,7 +791,7 @@ window_divider_width (struct window *w) will have a depressed look */ if (FRAME_WIN_P (XFRAME (WINDOW_FRAME (w)))) - return + return XINT (w->vertical_divider_line_width) + 2 * XINT (w->vertical_divider_spacing) + 2 * abs (XINT (w->vertical_divider_shadow_thickness)); @@ -893,7 +890,7 @@ window_modeline_height (struct window *w) /* This should be an abort except I'm not yet 100% confident that it won't ever get hit (though I haven't been able to trigger it). It is extremely - unlikely to cause any noticable problem and even if + unlikely to cause any noticeable problem and even if it does it will be a minor display glitch. */ /* #### Bullshit alert. It does get hit and it causes noticeable glitches. real_current_modeline_height @@ -1051,7 +1048,7 @@ int window_left_gutter_width (struct window *w, int modeline) { int gutter = window_left_toolbar_width (w); - + if (!NILP (w->hchild) || !NILP (w->vchild)) return 0; @@ -1067,8 +1064,8 @@ window_left_gutter_width (struct window *w, int modeline) int window_right_gutter_width (struct window *w, int modeline) { - int gutter = window_left_toolbar_width (w); - + int gutter = window_right_toolbar_width (w); + if (!NILP (w->hchild) || !NILP (w->vchild)) return 0; @@ -1404,7 +1401,7 @@ DEFUN ("window-text-area-pixel-width", Fwindow_text_area_pixel_width, 0, 1, 0, /* Return the width in pixels of the text-displaying portion of WINDOW. Unlike `window-pixel-width', the space occupied by the vertical -scrollbar or divider, if any, is not counted. +scrollbar or divider, if any, is not counted. */ (window)) { @@ -3168,7 +3165,7 @@ BUFFER can be a buffer or buffer name. Fset_marker (w->sb_point, w->start[CURRENT_DISP], buffer); /* set start_at_line_beg correctly. GE */ w->start_at_line_beg = beginning_of_line_p (XBUFFER (buffer), - marker_position (w->start[CURRENT_DISP])); + marker_position (w->start[CURRENT_DISP])); w->force_start = 0; /* Lucid fix */ SET_LAST_MODIFIED (w, 1); SET_LAST_FACECHANGE (w); @@ -3484,9 +3481,9 @@ and put SIZE columns in the first of the pair. DEFUN ("enlarge-window", Fenlarge_window, 1, 3, "_p", /* -Make the selected window ARG lines bigger. -From program, optional second arg non-nil means grow sideways ARG columns, -and optional third ARG specifies the window to change instead of the +Make the selected window N lines bigger. +From program, optional second arg SIDE non-nil means grow sideways N columns, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3498,9 +3495,9 @@ selected window. } DEFUN ("enlarge-window-pixels", Fenlarge_window_pixels, 1, 3, "_p", /* -Make the selected window ARG pixels bigger. -From program, optional second arg non-nil means grow sideways ARG pixels, -and optional third ARG specifies the window to change instead of the +Make the selected window N pixels bigger. +From program, optional second arg SIDE non-nil means grow sideways N pixels, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3512,9 +3509,9 @@ selected window. } DEFUN ("shrink-window", Fshrink_window, 1, 3, "_p", /* -Make the selected window ARG lines smaller. -From program, optional second arg non-nil means shrink sideways ARG columns, -and optional third ARG specifies the window to change instead of the +Make the selected window N lines smaller. +From program, optional second arg SIDE non-nil means shrink sideways N columns, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3526,9 +3523,9 @@ selected window. } DEFUN ("shrink-window-pixels", Fshrink_window_pixels, 1, 3, "_p", /* -Make the selected window ARG pixels smaller. -From program, optional second arg non-nil means shrink sideways ARG pixels, -and optional third ARG specifies the window to change instead of the +Make the selected window N pixels smaller. +From program, optional second arg SIDE non-nil means shrink sideways N pixels, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3912,7 +3909,7 @@ change_window_height (struct window *win, int delta, int widthflag, (*setsizefun) (window, *sizep + delta1, 0); /* Squeeze out delta1 lines or columns from our parent, - shriking this window and siblings proportionately. + shrinking this window and siblings proportionately. This brings parent back to correct size. Delta1 was calculated so this makes this window the desired size, taking it all out of the siblings. */ @@ -3957,7 +3954,7 @@ window_scroll (Lisp_Object window, Lisp_Object n, int direction, } /* Always set force_start so that redisplay_window will run - thw window-scroll-functions. */ + the window-scroll-functions. */ w->force_start = 1; /* #### When the fuck does this happen? I'm so glad that history has @@ -4130,10 +4127,10 @@ window_scroll (Lisp_Object window, Lisp_Object n, int direction, } DEFUN ("scroll-up", Fscroll_up, 0, 1, "_P", /* -Scroll text of current window upward ARG lines; or near full screen if no ARG. +Scroll text of current window upward N lines; or near full screen if no arg. A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll downward. -When calling from a program, supply a number as argument or nil. +Negative N means scroll downward. +When calling from a program, supply an integer as argument or nil. On attempt to scroll past end of buffer, `end-of-buffer' is signaled. On attempt to scroll past beginning of buffer, `beginning-of-buffer' is signaled. @@ -4145,9 +4142,9 @@ signaled. } DEFUN ("scroll-down", Fscroll_down, 0, 1, "_P", /* -Scroll text of current window downward ARG lines; or near full screen if no ARG. +Scroll text of current window downward N lines; or near full screen if no arg. A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll upward. +Negative N means scroll upward. When calling from a program, supply a number as argument or nil. On attempt to scroll past end of buffer, `end-of-buffer' is signaled. On attempt to scroll past beginning of buffer, `beginning-of-buffer' is @@ -4205,9 +4202,9 @@ showing that buffer is used. } DEFUN ("scroll-other-window", Fscroll_other_window, 0, 1, "_P", /* -Scroll next window upward ARG lines; or near full frame if no ARG. +Scroll next window upward N lines; or near full frame if no arg. 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 the current one is at the bottom. Negative N means scroll downward. When calling from a program, supply a number as argument or nil. If in the minibuffer, `minibuffer-scroll-window' if non-nil @@ -4222,37 +4219,33 @@ showing that buffer, popping the buffer up if necessary. } DEFUN ("scroll-left", Fscroll_left, 0, 1, "_P", /* -Scroll selected window display ARG columns left. -Default for ARG is window width minus 2. +Scroll selected window display N columns left. +Default for N is window width minus 2. */ - (arg)) + (n)) { Lisp_Object window = Fselected_window (Qnil); struct window *w = XWINDOW (window); + int count = (NILP (n) ? + window_char_width (w, 0) - 2 : + XINT (Fprefix_numeric_value (n))); - if (NILP (arg)) - arg = make_int (window_char_width (w, 0) - 2); - else - arg = Fprefix_numeric_value (arg); - - return Fset_window_hscroll (window, make_int (w->hscroll + XINT (arg))); + return Fset_window_hscroll (window, make_int (w->hscroll + count)); } DEFUN ("scroll-right", Fscroll_right, 0, 1, "_P", /* -Scroll selected window display ARG columns right. -Default for ARG is window width minus 2. +Scroll selected window display N columns right. +Default for N is window width minus 2. */ - (arg)) + (n)) { Lisp_Object window = Fselected_window (Qnil); struct window *w = XWINDOW (window); + int count = (NILP (n) ? + window_char_width (w, 0) - 2 : + XINT (Fprefix_numeric_value (n))); - if (NILP (arg)) - arg = make_int (window_char_width (w, 0) - 2); - else - arg = Fprefix_numeric_value (arg); - - return Fset_window_hscroll (window, make_int (w->hscroll - XINT (arg))); + return Fset_window_hscroll (window, make_int (w->hscroll - count)); } DEFUN ("center-to-window-line", Fcenter_to_window_line, 0, 2, "_P", /* @@ -4431,7 +4424,7 @@ map_windows_1 (Lisp_Object window, non-zero, the mapping is halted. Otherwise, map_windows() maps over all windows in F. - If MAPFUN creates or deletes windows, the behaviour is undefined. */ + If MAPFUN creates or deletes windows, the behavior is undefined. */ int map_windows (struct frame *f, int (*mapfun) (struct window *w, void *closure), @@ -4447,7 +4440,7 @@ map_windows (struct frame *f, int (*mapfun) (struct window *w, void *closure), { int v = map_windows_1 (FRAME_ROOT_WINDOW (XFRAME (XCAR (frmcons))), mapfun, closure); - if (v) + if (v) return v; } } @@ -4465,8 +4458,8 @@ modeline_shadow_thickness_changed (Lisp_Object specifier, struct window *w, } static void -vertical_divider_changed_in_window (Lisp_Object specifier, - struct window *w, +vertical_divider_changed_in_window (Lisp_Object specifier, + struct window *w, Lisp_Object oldval) { MARK_WINDOWS_CHANGED (w); @@ -4650,28 +4643,28 @@ mark_window_config (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct window_config *config = XWINDOW_CONFIGURATION (obj); int i; - ((markobj) (config->current_window)); - ((markobj) (config->current_buffer)); - ((markobj) (config->minibuffer_scroll_window)); - ((markobj) (config->root_window)); + markobj (config->current_window); + markobj (config->current_buffer); + markobj (config->minibuffer_scroll_window); + markobj (config->root_window); for (i = 0; i < config->saved_windows_count; i++) { struct saved_window *s = SAVED_WINDOW_N (config, i); - ((markobj) (s->window)); - ((markobj) (s->buffer)); - ((markobj) (s->start)); - ((markobj) (s->pointm)); - ((markobj) (s->sb_point)); - ((markobj) (s->mark)); + markobj (s->window); + markobj (s->buffer); + markobj (s->start); + markobj (s->pointm); + markobj (s->sb_point); + markobj (s->mark); #if 0 /* #### This looked like this. I do not see why specifier cached values should not be marked, as such specifiers as toolbars might have GC-able instances. Freed configs are not marked, aren't they? -- kkm */ - ((markobj) (s->dedicated)); + markobj (s->dedicated); #else -#define WINDOW_SLOT(slot, compare) ((markobj) (s->slot)) +#define WINDOW_SLOT(slot, compare) ((void) (markobj (s->slot))) #include "winslots.h" #endif } @@ -5605,7 +5598,7 @@ This is a specifier; use `set-specifier' to change it. modeline_shadow_thickness), modeline_shadow_thickness_changed, 0, 0); - + DEFVAR_SPECIFIER ("has-modeline-p", &Vhas_modeline_p /* *Whether the modeline should be displayed. This is a specifier; use `set-specifier' to change it. @@ -5643,7 +5636,7 @@ This is a specifier; use `set-specifier' to change it. 0, 0); DEFVAR_SPECIFIER ("vertical-divider-shadow-thickness", &Vvertical_divider_shadow_thickness /* -*How thick to draw 3D shadows around vertical dividers. +*How thick to draw 3D shadows around vertical dividers. This is a specifier; use `set-specifier' to change it. */ ); Vvertical_divider_shadow_thickness = Fmake_specifier (Qinteger); diff --git a/src/window.h b/src/window.h index 41cc210..fd2e291 100644 --- a/src/window.h +++ b/src/window.h @@ -28,7 +28,9 @@ Boston, MA 02111-1307, USA. */ #define _XEMACS_WINDOW_H_ #include "redisplay.h" +#ifdef HAVE_SCROLLBARS #include "scrollbar.h" +#endif /* All windows in use are arranged into a tree, with pointers up and down. diff --git a/src/xgccache.c b/src/xgccache.c index 959251a..956b809 100644 --- a/src/xgccache.c +++ b/src/xgccache.c @@ -43,7 +43,7 @@ Boston, MA 02111-1307, USA. */ used ones first). So if faces get changed, their GCs will eventually be recycled. Also more sharing of GCs is possible. - This code uses hashtables. It could be that, if the cache size is small + This code uses hash tables. It could be that, if the cache size is small enough, a linear search might be faster; but I doubt it, since we need `equal' comparisons, not `eq', and I expect that the optimal cache size will be ~100. @@ -84,7 +84,7 @@ struct gc_cache { struct gc_cache_cell *head; struct gc_cache_cell *tail; #ifdef GCCACHE_HASH - c_hashtable table; + struct hash_table *table; #endif int create_count; @@ -129,7 +129,7 @@ make_gc_cache (Display *dpy, Window window) cache->create_count = cache->delete_count = 0; #ifdef GCCACHE_HASH cache->table = - make_general_hashtable (GC_CACHE_SIZE, gc_cache_hash, gc_cache_eql); + make_general_hash_table (GC_CACHE_SIZE, gc_cache_hash, gc_cache_eql); #endif return cache; } @@ -147,7 +147,7 @@ free_gc_cache (struct gc_cache *cache) rest = next; } #ifdef GCCACHE_HASH - free_hashtable (cache->table); + free_hash_table (cache->table); #endif xfree (cache); } @@ -268,8 +268,6 @@ gc_cache_lookup (struct gc_cache *cache, XGCValues *gcv, unsigned long mask) #ifdef DEBUG_XEMACS -#include - void describe_gc_cache (struct gc_cache *cache); void describe_gc_cache (struct gc_cache *cache) @@ -290,32 +288,35 @@ describe_gc_cache (struct gc_cache *cache) gc_cache_hash (&cell->gcvm) == gc_cache_hash (&cell2->gcvm)) stderr_out ("\tHASH COLLISION with cell %d\n", i); stderr_out ("\tmask: %8lx\n", cell->gcvm.mask); -#define F(x) (int)cell->gcvm.gcv.x -#define G(w,x) if (F(x) != (~0)) stderr_out ("\t%-12s%8x\n", w, F(x)) - G("function:", function); - G("plane_mask:", plane_mask); - G("foreground:", foreground); - G("background:", background); - G("line_width:", line_width); - G("line_style:", line_style); - G("cap_style:", cap_style); - G("join_style:", join_style); - G("fill_style:", fill_style); - G("fill_rule:", fill_rule); - G("arc_mode:", arc_mode); - G("tile:", tile); - G("stipple:", stipple); - G("tsx_origin:", ts_x_origin); - G("tsy_origin:", ts_y_origin); - G("font:", font); - G("subwindow:", subwindow_mode); - G("gexposures:", graphics_exposures); - G("clip_x:", clip_x_origin); - G("clip_y:", clip_y_origin); - G("clip_mask:", clip_mask); - G("dash_off:", dash_offset); -#undef F -#undef G + +#define FROB(field) do { \ + if ((int)cell->gcvm.gcv.field != (~0)) \ + stderr_out ("\t%-12s%8x\n", #field ":", (int)cell->gcvm.gcv.field); \ +} while (0) + FROB (function); + FROB (plane_mask); + FROB (foreground); + FROB (background); + FROB (line_width); + FROB (line_style); + FROB (cap_style); + FROB (join_style); + FROB (fill_style); + FROB (fill_rule); + FROB (arc_mode); + FROB (tile); + FROB (stipple); + FROB (ts_x_origin); + FROB (ts_y_origin); + FROB (font); + FROB (subwindow_mode); + FROB (graphics_exposures); + FROB (clip_x_origin); + FROB (clip_y_origin); + FROB (clip_mask); + FROB (dash_offset); +#undef FROB + count++; if (cell->next && cell == cache->tail) stderr_out ("\nERROR! tail is here!\n\n"); diff --git a/src/xmu.c b/src/xmu.c index 943d24f..1f1261a 100644 --- a/src/xmu.c +++ b/src/xmu.c @@ -158,7 +158,7 @@ int XmuCursorNameToIndex (CONST char *name) /* - * Based on an optimized version provided by Jim Becker, Auguest 5, 1988. + * Based on an optimized version provided by Jim Becker, August 5, 1988. */ @@ -388,7 +388,7 @@ int XmuReadBitmapDataFromFile (CONST char *filename, /* * XmuPrintDefaultErrorMessage - print a nice error that looks like the usual - * message. Returns 1 if the caller should consider exitting else 0. + * message. Return 1 if the caller should consider exiting, else 0. */ int XmuPrintDefaultErrorMessage (Display *dpy, XErrorEvent *event, FILE *fp) { diff --git a/tests/automated/byte-compiler-tests.el b/tests/automated/byte-compiler-tests.el new file mode 100644 index 0000000..efd7bf5 --- /dev/null +++ b/tests/automated/byte-compiler-tests.el @@ -0,0 +1,93 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test byte-compiler functionality +;;; See test-harness.el + +(condition-case err + (require 'test-harness) + (file-error + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path) + (require 'test-harness)))) + +(require 'bytecomp) + +;; test constant symbol warnings +(defmacro check-byte-compiler-message (message-regexp &rest body) + `(Check-Message ,message-regexp (byte-compile '(lambda () ,@body)))) + +(check-byte-compiler-message "Attempt to set non-symbol" (setq 1 1)) +(check-byte-compiler-message "Attempt to set constant symbol" (setq t 1)) +(check-byte-compiler-message "Attempt to set constant symbol" (setq nil 1)) +(check-byte-compiler-message "^$" (defconst :foo 1)) + +(check-byte-compiler-message "Attempt to let-bind non-symbol" (let ((1 'x)) 1)) +(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((t 'x)) (foo))) +(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((nil 'x)) (foo))) +(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((:foo 'x)) (foo))) + + +(check-byte-compiler-message "bound but not referenced" (let ((foo 'x)) 1)) +(Assert (not (boundp 'free-variable))) +(Assert (boundp 'byte-compile-warnings)) +(check-byte-compiler-message "assignment to free variable" (setq free-variable 1)) +(check-byte-compiler-message "reference to free variable" (car free-variable)) +(check-byte-compiler-message "called with 2 args, but requires 1" (car 'x 'y)) + +(check-byte-compiler-message "^$" (setq :foo 1)) +(let ((fun '(lambda () (setq :foo 1)))) + (fset 'test-byte-compiler-fun fun)) +(Check-Error setting-constant (test-byte-compiler-fun)) +(byte-compile 'test-byte-compiler-fun) +(Check-Error setting-constant (test-byte-compiler-fun)) + +(eval-when-compile (defvar setq-test-foo nil) (defvar setq-test-bar nil)) +(progn + (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo)) + (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo 1 setq-test-bar)) + (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo)) + (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo 1 setq-test-bar)) + ) + +;;----------------------------------------------------- +;; let, let* +;;----------------------------------------------------- + +;; Test interpreted and compiled lisp separately here +(check-byte-compiler-message "malformed let binding" (let ((x 1 2)) 3)) +(check-byte-compiler-message "malformed let binding" (let* ((x 1 2)) 3)) + +(Check-Error-Message + error "`let' bindings can have only one value-form" + (eval '(let ((x 1 2)) 3))) + +(Check-Error-Message + error "`let' bindings can have only one value-form" + (eval '(let* ((x 1 2)) 3))) + diff --git a/tests/automated/database-tests.el b/tests/automated/database-tests.el new file mode 100644 index 0000000..7a46c34 --- /dev/null +++ b/tests/automated/database-tests.el @@ -0,0 +1,62 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests, database + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test database functionality +;;; See test-harness.el + +(condition-case err + (require 'test-harness) + (file-error + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path) + (require 'test-harness)))) + +(flet ((test-database + (db) + (Assert (databasep db)) + (put-database "key1" "val1" db) + (Assert (equal "val1" (get-database "key1" db))) + (remove-database "key1" db) + (Assert (equal nil (get-database "key1" db))) + (close-database db) + (Assert (not (database-live-p db))) + (Assert (databasep db)) + (let ((filename (database-file-name db))) + (dolist (fn (list filename (concat filename ".db"))) + (condition-case nil (delete-file fn) (file-error nil)))))) + + (let ((filename (expand-file-name "test-harness" (temp-directory)))) + + (dolist (fn (list filename (concat filename ".db"))) + (condition-case nil (delete-file fn) (file-error nil))) + + (dolist (db-type `(dbm berkeley-db)) + (when (featurep db-type) + (princ "\n") + (test-database (open-database filename db-type)))) + )) diff --git a/tests/automated/hash-table-tests.el b/tests/automated/hash-table-tests.el new file mode 100644 index 0000000..c813f5f --- /dev/null +++ b/tests/automated/hash-table-tests.el @@ -0,0 +1,269 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests, database + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test database functionality +;;; See test-harness.el + +(condition-case err + (require 'test-harness) + (file-error + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path) + (require 'test-harness)))) + +;; Test all combinations of make-hash-table keywords +(dolist (type `(non-weak weak key-weak value-weak)) + (dolist (test `(eq eql equal)) + (dolist (size `(0 1 100)) + (dolist (rehash-size `(1.1 9.9)) + (dolist (rehash-threshold `(0.2 .9)) + (dolist (data `(() (1 2) (1 2 3 4))) + (let ((ht (make-hash-table :test test + :type type + :size size + :rehash-size rehash-size + :rehash-threshold rehash-threshold))) + (Assert (equal ht (car (let ((print-readably t)) + (read-from-string (prin1-to-string ht)))))) + (Assert (eq test (hash-table-test ht))) + (Assert (eq type (hash-table-type ht))) + (Assert (<= size (hash-table-size ht))) + (Assert (eql rehash-size (hash-table-rehash-size ht))) + (Assert (eql rehash-threshold (hash-table-rehash-threshold ht)))))))))) + +(loop for (fun type) in `((make-hashtable non-weak) + (make-weak-hashtable weak) + (make-key-weak-hashtable key-weak) + (make-value-weak-hashtable value-weak)) + do (Assert (eq type (hash-table-type (funcall fun 10))))) + +(let ((ht (make-hash-table :size 20 :rehash-threshold .75 :test 'eq)) + (size 80)) + (Assert (hashtablep ht)) + (Assert (hash-table-p ht)) + (Assert (eq 'eq (hash-table-test ht))) + (Assert (eq 'non-weak (hash-table-type ht))) + (Assert (eq 'non-weak (hashtable-type ht))) + (dotimes (j size) + (puthash j (- j) ht) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j))) + (Assert (= (hashtable-fullness ht) (hash-table-count ht))) + (puthash j j ht) + (Assert (eq (gethash j ht 'foo) j)) + (Assert (= (hash-table-count ht) (1+ j))) + (setf (gethash j ht) (- j)) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) + + (clrhash ht) + (Assert (= 0 (hash-table-count ht))) + + (dotimes (j size) + (puthash j (- j) ht) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) + + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) + (print k-sum) + (print v-sum) + (Assert (= k-sum (/ (* size (- size 1)) 2))) + (Assert (= v-sum (- k-sum)))) + + (let ((count size)) + (dotimes (j size) + (remhash j ht) + (Assert (eq (gethash j ht) nil)) + (Assert (eq (gethash j ht 'foo) 'foo)) + (Assert (= (hash-table-count ht) (decf count)))))) + +(let ((ht (make-hash-table :size 30 :rehash-threshold .25 :test 'equal)) + (size 70)) + (Assert (hashtablep ht)) + (Assert (hash-table-p ht)) + (Assert (>= (hash-table-size ht) (/ 30 .25))) + (Assert (eql .25 (hash-table-rehash-threshold ht))) + (Assert (eq 'equal (hash-table-test ht))) + (Assert (eq (hash-table-test ht) (hashtable-test-function ht))) + (Assert (eq 'non-weak (hash-table-type ht))) + (dotimes (j size) + (puthash (int-to-string j) (- j) ht) + (Assert (eq (gethash (int-to-string j) ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j))) + (puthash (int-to-string j) j ht) + (Assert (eq (gethash (int-to-string j) ht 'foo) j)) + (Assert (= (hash-table-count ht) (1+ j)))) + + (clrhash ht) + (Assert (= 0 (hash-table-count ht))) + (Assert (equal ht (copy-hash-table ht))) + + (dotimes (j size) + (setf (gethash (int-to-string j) ht) (- j)) + (Assert (eq (gethash (int-to-string j) ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) + + (let ((count size)) + (dotimes (j size) + (remhash (int-to-string j) ht) + (Assert (eq (gethash (int-to-string j) ht) nil)) + (Assert (eq (gethash (int-to-string j) ht 'foo) 'foo)) + (Assert (= (hash-table-count ht) (decf count)))))) + +(let ((iterations 5) (one 1.0) (two 2.0)) + (flet ((check-copy + (ht) + (let ((copy-of-ht (copy-hash-table ht))) + (Assert (equal ht copy-of-ht)) + (Assert (not (eq ht copy-of-ht))) + (Assert (eq (hash-table-count ht) (hash-table-count copy-of-ht))) + (Assert (eq (hash-table-type ht) (hash-table-type copy-of-ht))) + (Assert (eq (hash-table-size ht) (hash-table-size copy-of-ht))) + (Assert (eql (hash-table-rehash-size ht) (hash-table-rehash-size copy-of-ht))) + (Assert (eql (hash-table-rehash-threshold ht) (hash-table-rehash-threshold copy-of-ht)))))) + + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eq))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash (+ two 0.0) t ht) + (puthash (concat "1" "2") t ht) + (puthash (concat "3" "4") t ht)) + (Assert (eq (hashtable-test-function ht) 'eq)) + (Assert (eq (hash-table-test ht) 'eq)) + (Assert (= (* iterations 4) (hash-table-count ht))) + (Assert (eq nil (gethash 1.0 ht))) + (Assert (eq nil (gethash "12" ht))) + (check-copy ht) + ) + + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eql))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash (+ two 0.0) t ht) + (puthash (concat "1" "2") t ht) + (puthash (concat "3" "4") t ht)) + (Assert (eq (hashtable-test-function ht) 'eql)) + (Assert (eq (hash-table-test ht) 'eql)) + (Assert (= (+ 2 (* 2 iterations)) (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq nil (gethash "12" ht))) + (check-copy ht) + ) + + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'equal))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash (+ two 0.0) t ht) + (puthash (concat "1" "2") t ht) + (puthash (concat "3" "4") t ht)) + (Assert (eq (hashtable-test-function ht) 'equal)) + (Assert (eq (hash-table-test ht) 'equal)) + (Assert (= 4 (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq t (gethash "12" ht))) + (check-copy ht) + ) + + )) + +;; Test that weak hash-tables are properly handled +(loop for (type expected-count expected-k-sum expected-v-sum) in + `((non-weak 6 38 25) + (weak 3 6 9) + (key-weak 4 38 9) + (value-weak 4 6 25)) + do + (let* ((ht (make-hash-table :type type)) + (my-obj (cons ht ht))) + (garbage-collect) + (puthash my-obj 1 ht) + (puthash 2 my-obj ht) + (puthash 4 8 ht) + (puthash (cons ht ht) 16 ht) + (puthash 32 (cons ht ht) ht) + (puthash (cons ht ht) (cons ht ht) ht) + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) + (when (integerp k) (incf k-sum k)) + (when (integerp v) (incf v-sum v))) + ht) + (Assert (eq 38 k-sum)) + (Assert (eq 25 v-sum))) + (Assert (eq 6 (hash-table-count ht))) + (garbage-collect) + (Assert (eq expected-count (hash-table-count ht))) + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) + (when (integerp k) (incf k-sum k)) + (when (integerp v) (incf v-sum v))) + ht) + (Assert (eq expected-k-sum k-sum)) + (Assert (eq expected-v-sum v-sum))))) + +;;; Test the ability to puthash and remhash the current elt of a maphash +(let ((ht (make-hash-table :test 'eql))) + (dotimes (j 100) (setf (gethash j ht) (- j))) + (maphash #'(lambda (k v) + (if (oddp k) (remhash k ht) (puthash k (- v) ht))) + ht) + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) + (Assert (= (* 50 49) k-sum)) + (Assert (= v-sum k-sum)))) + +;;; Test reading and printing of hash-table objects +(let ((h1 #s(hashtable type weak rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) + (h2 #s(hash-table type weak rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) + (h3 (make-hash-table :type 'weak :rehash-size 3.0 :rehash-threshold .2 :test 'eq))) + (Assert (equal h1 h2)) + (Assert (not (equal h1 h3))) + (puthash 1 2 h3) + (puthash 3 4 h3) + (Assert (equal h1 h3))) + +;;; Testing equality of hash tables +(Assert (equal (make-hash-table :test 'eql :size 300 :rehash-threshold .9 :rehash-size 3.0) + (make-hash-table :test 'eql))) +(Assert (not (equal (make-hash-table :test 'eq) + (make-hash-table :test 'equal)))) +(let ((h1 (make-hash-table)) + (h2 (make-hash-table))) + (Assert (equal h1 h2)) + (Assert (not (eq h1 h2))) + (puthash 1 2 h1) + (Assert (not (equal h1 h2))) + (puthash 1 2 h2) + (Assert (equal h1 h2)) + (puthash 1 3 h2) + (Assert (not (equal h1 h2))) + (clrhash h1) + (Assert (not (equal h1 h2))) + (clrhash h2) + (Assert (equal h1 h2)) + ) diff --git a/tests/automated/lisp-tests.el b/tests/automated/lisp-tests.el new file mode 100644 index 0000000..f42f5d8 --- /dev/null +++ b/tests/automated/lisp-tests.el @@ -0,0 +1,727 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test basic Lisp engine functionality +;;; See test-harness.el for instructions on how to run these tests. + +(eval-when-compile + (condition-case nil + (require 'test-harness) + (file-error + (push "." load-path) + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path)) + (require 'test-harness)))) + +(Check-Error wrong-number-of-arguments (setq setq-test-foo)) +(Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) +(Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) +(Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) +(Assert (eq (setq) nil)) +(Assert (eq (setq-default) nil)) +(Assert (eq (setq setq-test-foo 42) 42)) +(Assert (eq (setq-default setq-test-foo 42) 42)) +(Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99)) +(Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)) + +(macrolet ((test-setq (expected-result &rest body) + `(progn + (defun test-setq-fun () ,@body) + (Assert (eq ,expected-result (test-setq-fun))) + (byte-compile 'test-setq-fun) + (Assert (eq ,expected-result (test-setq-fun)))))) + (test-setq nil (setq)) + (test-setq nil (setq-default)) + (test-setq 42 (setq test-setq-var 42)) + (test-setq 42 (setq-default test-setq-var 42)) + (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) + (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) + ) + +(let ((my-vector [1 2 3 4]) + (my-bit-vector (bit-vector 1 0 1 0)) + (my-string "1234") + (my-list '(1 2 3 4))) + + ;;(Assert (fooooo)) ;; Generate Other failure + ;;(Assert (eq 1 2)) ;; Generate Assertion failure + + (dolist (sequence (list my-vector my-bit-vector my-string my-list)) + (Assert (sequencep sequence)) + (Assert (eq 4 (length sequence)))) + + (dolist (array (list my-vector my-bit-vector my-string)) + (Assert (arrayp array))) + + (Assert (eq (elt my-vector 0) 1)) + (Assert (eq (elt my-bit-vector 0) 1)) + (Assert (eq (elt my-string 0) ?1)) + (Assert (eq (elt my-list 0) 1)) + + (fillarray my-vector 5) + (fillarray my-bit-vector 1) + (fillarray my-string ?5) + + (dolist (array (list my-vector my-bit-vector)) + (Assert (eq 4 (length array)))) + + (Assert (eq (elt my-vector 0) 5)) + (Assert (eq (elt my-bit-vector 0) 1)) + (Assert (eq (elt my-string 0) ?5)) + + (Assert (eq (elt my-vector 3) 5)) + (Assert (eq (elt my-bit-vector 3) 1)) + (Assert (eq (elt my-string 3) ?5)) + + (fillarray my-bit-vector 0) + (Assert (eq 4 (length my-bit-vector))) + (Assert (eq (elt my-bit-vector 2) 0)) + ) + +(defun make-circular-list (length) + "Create evil emacs-crashing circular list of length LENGTH" + (let ((circular-list + (make-list + length + 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) + (setcdr (last circular-list) circular-list) + circular-list)) + +;;----------------------------------------------------- +;; Test `nconc' +;;----------------------------------------------------- +(defun make-list-012 () (list 0 1 2)) + +(Check-Error wrong-type-argument (nconc 'foo nil)) + +(dolist (length `(1 2 3 4 1000 2000)) + (Check-Error circular-list (nconc (make-circular-list length) 'foo)) + (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) + (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) + +(Assert (eq (nconc) nil)) +(Assert (eq (nconc nil) nil)) +(Assert (eq (nconc nil nil) nil)) +(Assert (eq (nconc nil nil nil) nil)) + +(let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x nil) x))) +(let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x))) + +(Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) + +(let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) + (Assert (eq (length y) 6)) + (Assert (eq (nth 3 y) 3))) + +;;----------------------------------------------------- +;; Test `last' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (last 'foo)) +(Check-Error wrong-number-of-arguments (last)) +(Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) +(Check-Error circular-list (last (make-circular-list 1))) +(Check-Error circular-list (last (make-circular-list 2000))) +(let ((x (list 0 1 2 3))) + (Assert (eq (last nil) nil)) + (Assert (eq (last x 0) nil)) + (Assert (eq (last x ) (cdddr x))) + (Assert (eq (last x 1) (cdddr x))) + (Assert (eq (last x 2) (cddr x))) + (Assert (eq (last x 3) (cdr x))) + (Assert (eq (last x 4) x)) + (Assert (eq (last x 9) x)) + (Assert (eq (last `(1 . 2) 0) 2)) + ) + +;;----------------------------------------------------- +;; Test `butlast' and `nbutlast' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (butlast 'foo)) +(Check-Error wrong-type-argument (nbutlast 'foo)) +(Check-Error wrong-number-of-arguments (butlast)) +(Check-Error wrong-number-of-arguments (nbutlast)) +(Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) +(Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) +(Check-Error circular-list (butlast (make-circular-list 1))) +(Check-Error circular-list (nbutlast (make-circular-list 1))) +(Check-Error circular-list (butlast (make-circular-list 2000))) +(Check-Error circular-list (nbutlast (make-circular-list 2000))) + +(let* ((x (list 0 1 2 3)) + (y (butlast x)) + (z (nbutlast x))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2))) + (Assert (equal z y))) + +(let* ((x (list 0 1 2 3 4)) + (y (butlast x 2)) + (z (nbutlast x 2))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2))) + (Assert (equal z y))) + +(let* ((x (list 0 1 2 3)) + (y (butlast x 0)) + (z (nbutlast x 0))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2 3))) + (Assert (equal z y))) + +(Assert (eq (butlast '(x)) nil)) +(Assert (eq (nbutlast '(x)) nil)) +(Assert (eq (butlast '()) nil)) +(Assert (eq (nbutlast '()) nil)) + +;;----------------------------------------------------- +;; Test `copy-list' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (copy-list 'foo)) +(Check-Error wrong-number-of-arguments (copy-list)) +(Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) +(Check-Error circular-list (copy-list (make-circular-list 1))) +(Check-Error circular-list (copy-list (make-circular-list 2000))) +(Assert (eq '() (copy-list '()))) +(dolist (x `((1) (1 2) (1 2 3) (1 2 . 3))) + (let ((y (copy-list x))) + (Assert (and (equal x y) (not (eq x y)))))) + +;;----------------------------------------------------- +;; Arithmetic operations +;;----------------------------------------------------- + +;; Test `+' +(Assert (eq (+ 1 1) 2)) +(Assert (= (+ 1.0 1.0) 2.0)) +(Assert (= (+ 1.0 3.0 0.0) 4.0)) +(Assert (= (+ 1 1.0) 2.0)) +(Assert (= (+ 1.0 1) 2.0)) +(Assert (= (+ 1.0 1 1) 3.0)) +(Assert (= (+ 1 1 1.0) 3.0)) + +;; Test `-' +(Check-Error wrong-number-of-arguments (-)) +(Assert (eq (- 0) 0)) +(Assert (eq (- 1) -1)) +(dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) + (Assert (= (+ 1 one) 2)) + (Assert (= (+ one) 1)) + (Assert (= (+ one) one)) + (Assert (= (- one) -1)) + (Assert (= (- one one) 0)) + (Assert (= (- one one one) -1)) + (Assert (= (+ one 1) 2)) + (dolist (zero `(0 0.0 ?\0)) + (Assert (= (+ 1 zero) 1)) + (Assert (= (+ zero 1) 1)) + (Assert (= (- zero) zero)) + (Assert (= (- zero) 0)) + (Assert (= (- zero zero) 0)) + (Assert (= (- zero one one) -2)))) + +(Assert (= (- 1.5 1) .5)) +(Assert (= (- 1 1.5) (- .5))) + +;; Test `/' + +;; Test division by zero errors +(dolist (zero `(0 0.0 ?\0)) + (Check-Error arith-error (/ zero)) + (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) + (Check-Error arith-error (/ n1 zero)) + (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) + (Check-Error arith-error (/ n1 n2 zero))))) + +;; Other tests for `/' +(Check-Error wrong-number-of-arguments (/)) +(let (x) + (Assert (= (/ (setq x 2)) 0)) + (Assert (= (/ (setq x 2.0)) 0.5))) + +(dolist (six `(6 6.0 ?\06)) + (dolist (two `(2 2.0 ?\02)) + (dolist (three `(3 3.0 ?\03)) + (Assert (= (/ six two) three))))) + +(dolist (three `(3 3.0 ?\03)) + (Assert (= (/ three 2.0) 1.5))) +(dolist (two `(2 2.0 ?\02)) + (Assert (= (/ 3.0 two) 1.5))) + +;; Test `*' +(Assert (= 1 (*))) + +(dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) + (Assert (= 1 (* one)))) + +(dolist (two `(2 2.0 ?\02)) + (Assert (= 2 (* two)))) + +(dolist (six `(6 6.0 ?\06)) + (dolist (two `(2 2.0 ?\02)) + (dolist (three `(3 3.0 ?\03)) + (Assert (= (* three two) six))))) + +(dolist (three `(3 3.0 ?\03)) + (dolist (two `(2 2.0 ?\02)) + (Assert (= (* 1.5 two) three)) + (dolist (five `(5 5.0 ?\05)) + (Assert (= 30 (* five two three)))))) + +;; Test `+' +(Assert (= 0 (+))) + +(dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) + (Assert (= 1 (+ one)))) + +(dolist (two `(2 2.0 ?\02)) + (Assert (= 2 (+ two)))) + +(dolist (five `(5 5.0 ?\05)) + (dolist (two `(2 2.0 ?\02)) + (dolist (three `(3 3.0 ?\03)) + (Assert (= (+ three two) five)) + (Assert (= 10 (+ five two three)))))) + +;; Test `max', `min' +(dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) + (Assert (= one (max one))) + (Assert (= one (max one one))) + (Assert (= one (max one one one))) + (Assert (= one (min one))) + (Assert (= one (min one one))) + (Assert (= one (min one one one))) + (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) + (Assert (= one (min one two))) + (Assert (= one (min one two two))) + (Assert (= one (min two two one))) + (Assert (= two (max one two))) + (Assert (= two (max one two two))) + (Assert (= two (max two two one))))) + +;;----------------------------------------------------- +;; Logical bit-twiddling operations +;;----------------------------------------------------- +(Assert (= (logxor) 0)) +(Assert (= (logior) 0)) +(Assert (= (logand) -1)) + +(Check-Error wrong-type-argument (logxor 3.0)) +(Check-Error wrong-type-argument (logior 3.0)) +(Check-Error wrong-type-argument (logand 3.0)) + +(dolist (three `(3 ?\03)) + (Assert (eq 3 (logand three))) + (Assert (eq 3 (logxor three))) + (Assert (eq 3 (logior three))) + (Assert (eq 3 (logand three three))) + (Assert (eq 0 (logxor three three))) + (Assert (eq 3 (logior three three)))) + +(dolist (one `(1 ?\01 ,(Int-to-Marker 1))) + (dolist (two `(2 ?\02)) + (Assert (eq 0 (logand one two))) + (Assert (eq 3 (logior one two))) + (Assert (eq 3 (logxor one two)))) + (dolist (three `(3 ?\03)) + (Assert (eq 1 (logand one three))) + (Assert (eq 3 (logior one three))) + (Assert (eq 2 (logxor one three))))) + +;;----------------------------------------------------- +;; Test `%', mod +;;----------------------------------------------------- +(Check-Error wrong-number-of-arguments (%)) +(Check-Error wrong-number-of-arguments (% 1)) +(Check-Error wrong-number-of-arguments (% 1 2 3)) + +(Check-Error wrong-number-of-arguments (mod)) +(Check-Error wrong-number-of-arguments (mod 1)) +(Check-Error wrong-number-of-arguments (mod 1 2 3)) + +(Check-Error wrong-type-argument (% 10.0 2)) +(Check-Error wrong-type-argument (% 10 2.0)) + +(dotimes (j 30) + (let ((x (- (random) (random)))) + (Assert (eq x (+ (% x 17) (* (/ x 17) 17)))) + (Assert (eq (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)))) + (Assert (eq (% x -17) (- (% (- x) 17)))) + )) + +(macrolet + ((division-test (seven) + `(progn + (Assert (eq (% ,seven 2) 1)) + (Assert (eq (% ,seven -2) 1)) + (Assert (eq (% (- ,seven) 2) -1)) + (Assert (eq (% (- ,seven) -2) -1)) + + (Assert (eq (% ,seven 4) 3)) + (Assert (eq (% ,seven -4) 3)) + (Assert (eq (% (- ,seven) 4) -3)) + (Assert (eq (% (- ,seven) -4) -3)) + + (Assert (eq (% 35 ,seven) 0)) + (Assert (eq (% -35 ,seven) 0)) + (Assert (eq (% 35 (- ,seven)) 0)) + (Assert (eq (% -35 (- ,seven)) 0)) + + (Assert (eq (mod ,seven 2) 1)) + (Assert (eq (mod ,seven -2) -1)) + (Assert (eq (mod (- ,seven) 2) 1)) + (Assert (eq (mod (- ,seven) -2) -1)) + + (Assert (eq (mod ,seven 4) 3)) + (Assert (eq (mod ,seven -4) -1)) + (Assert (eq (mod (- ,seven) 4) 1)) + (Assert (eq (mod (- ,seven) -4) -3)) + + (Assert (eq (mod 35 ,seven) 0)) + (Assert (eq (mod -35 ,seven) 0)) + (Assert (eq (mod 35 (- ,seven)) 0)) + (Assert (eq (mod -35 (- ,seven)) 0)) + + (Assert (= (mod ,seven 2.0) 1.0)) + (Assert (= (mod ,seven -2.0) -1.0)) + (Assert (= (mod (- ,seven) 2.0) 1.0)) + (Assert (= (mod (- ,seven) -2.0) -1.0)) + + (Assert (= (mod ,seven 4.0) 3.0)) + (Assert (= (mod ,seven -4.0) -1.0)) + (Assert (= (mod (- ,seven) 4.0) 1.0)) + (Assert (= (mod (- ,seven) -4.0) -3.0)) + + (Assert (eq (% 0 ,seven) 0)) + (Assert (eq (% 0 (- ,seven)) 0)) + + (Assert (eq (mod 0 ,seven) 0)) + (Assert (eq (mod 0 (- ,seven)) 0)) + + (Assert (= (mod 0.0 ,seven) 0.0)) + (Assert (= (mod 0.0 (- ,seven)) 0.0))))) + + (division-test 7) + (division-test ?\07) + (division-test (Int-to-Marker 7))) + + + +;;----------------------------------------------------- +;; Arithmetic comparison operations +;;----------------------------------------------------- +(Check-Error wrong-number-of-arguments (=)) +(Check-Error wrong-number-of-arguments (<)) +(Check-Error wrong-number-of-arguments (>)) +(Check-Error wrong-number-of-arguments (<=)) +(Check-Error wrong-number-of-arguments (>=)) +(Check-Error wrong-number-of-arguments (/=)) + +;; One argument always yields t +(loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do + (Assert (eq t (= x))) + (Assert (eq t (< x))) + (Assert (eq t (> x))) + (Assert (eq t (>= x))) + (Assert (eq t (<= x))) + (Assert (eq t (/= x))) + ) + +;; Type checking +(Check-Error wrong-type-argument (= 'foo 1)) +(Check-Error wrong-type-argument (<= 'foo 1)) +(Check-Error wrong-type-argument (>= 'foo 1)) +(Check-Error wrong-type-argument (< 'foo 1)) +(Check-Error wrong-type-argument (> 'foo 1)) +(Check-Error wrong-type-argument (/= 'foo 1)) + +;; Meat +(dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) + (dolist (two `(2 2.0 ?\02)) + (Assert (< one two)) + (Assert (<= one two)) + (Assert (<= two two)) + (Assert (> two one)) + (Assert (>= two one)) + (Assert (>= two two)) + (Assert (/= one two)) + (Assert (not (/= two two))) + (Assert (not (< one one))) + (Assert (not (> one one))) + (Assert (<= one one two two)) + (Assert (not (< one one two two))) + (Assert (>= two two one one)) + (Assert (not (> two two one one))) + (Assert (= one one one)) + (Assert (not (= one one one two))) + (Assert (not (/= one two one))) + )) + +(dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) + (dolist (two `(2 2.0 ?\02)) + (Assert (< one two)) + (Assert (<= one two)) + (Assert (<= two two)) + (Assert (> two one)) + (Assert (>= two one)) + (Assert (>= two two)) + (Assert (/= one two)) + (Assert (not (/= two two))) + (Assert (not (< one one))) + (Assert (not (> one one))) + (Assert (<= one one two two)) + (Assert (not (< one one two two))) + (Assert (>= two two one one)) + (Assert (not (> two two one one))) + (Assert (= one one one)) + (Assert (not (= one one one two))) + (Assert (not (/= one two one))) + )) + +;; ad-hoc +(Assert (< 1 2)) +(Assert (< 1 2 3 4 5 6)) +(Assert (not (< 1 1))) +(Assert (not (< 2 1))) + + +(Assert (not (< 1 1))) +(Assert (< 1 2 3 4 5 6)) +(Assert (<= 1 2 3 4 5 6)) +(Assert (<= 1 2 3 4 5 6 6)) +(Assert (not (< 1 2 3 4 5 6 6))) +(Assert (<= 1 1)) + +(Assert (not (eq (point) (point-marker)))) +(Assert (= 1 (Int-to-Marker 1))) +(Assert (= (point) (point-marker))) + +;;----------------------------------------------------- +;; testing list-walker functions +;;----------------------------------------------------- +(macrolet + ((test-fun + (fun) + `(progn + (Check-Error wrong-number-of-arguments (,fun)) + (Check-Error wrong-number-of-arguments (,fun nil)) + (Check-Error malformed-list (,fun nil 1)) + ,@(loop for n in `(1 2 2000) + collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) + (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) + + (test-funs member old-member + memq old-memq + assoc old-assoc + rassoc old-rassoc + rassq old-rassq + delete old-delete + delq old-delq + remassoc remassq remrassoc remrassq)) + +(let ((x '((1 . 2) 3 (4 . 5)))) + (Assert (eq (assoc 1 x) (car x))) + (Assert (eq (assq 1 x) (car x))) + (Assert (eq (rassoc 1 x) nil)) + (Assert (eq (rassq 1 x) nil)) + (Assert (eq (assoc 2 x) nil)) + (Assert (eq (assq 2 x) nil)) + (Assert (eq (rassoc 2 x) (car x))) + (Assert (eq (rassq 2 x) (car x))) + (Assert (eq (assoc 3 x) nil)) + (Assert (eq (assq 3 x) nil)) + (Assert (eq (rassoc 3 x) nil)) + (Assert (eq (rassq 3 x) nil)) + (Assert (eq (assoc 4 x) (caddr x))) + (Assert (eq (assq 4 x) (caddr x))) + (Assert (eq (rassoc 4 x) nil)) + (Assert (eq (rassq 4 x) nil)) + (Assert (eq (assoc 5 x) nil)) + (Assert (eq (assq 5 x) nil)) + (Assert (eq (rassoc 5 x) (caddr x))) + (Assert (eq (rassq 5 x) (caddr x))) + (Assert (eq (assoc 6 x) nil)) + (Assert (eq (assq 6 x) nil)) + (Assert (eq (rassoc 6 x) nil)) + (Assert (eq (rassq 6 x) nil))) + +(let ((x '(("1" . "2") "3" ("4" . "5")))) + (Assert (eq (assoc "1" x) (car x))) + (Assert (eq (assq "1" x) nil)) + (Assert (eq (rassoc "1" x) nil)) + (Assert (eq (rassq "1" x) nil)) + (Assert (eq (assoc "2" x) nil)) + (Assert (eq (assq "2" x) nil)) + (Assert (eq (rassoc "2" x) (car x))) + (Assert (eq (rassq "2" x) nil)) + (Assert (eq (assoc "3" x) nil)) + (Assert (eq (assq "3" x) nil)) + (Assert (eq (rassoc "3" x) nil)) + (Assert (eq (rassq "3" x) nil)) + (Assert (eq (assoc "4" x) (caddr x))) + (Assert (eq (assq "4" x) nil)) + (Assert (eq (rassoc "4" x) nil)) + (Assert (eq (rassq "4" x) nil)) + (Assert (eq (assoc "5" x) nil)) + (Assert (eq (assq "5" x) nil)) + (Assert (eq (rassoc "5" x) (caddr x))) + (Assert (eq (rassq "5" x) nil)) + (Assert (eq (assoc "6" x) nil)) + (Assert (eq (assq "6" x) nil)) + (Assert (eq (rassoc "6" x) nil)) + (Assert (eq (rassq "6" x) nil))) + +(flet ((a () (list '(1 . 2) 3 '(4 . 5)))) + (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + + (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + + (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + + (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) + ) + + + +(flet ((a () (list '("1" . "2") "3" '("4" . "5")))) + (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) + (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) + (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) + (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) + (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) + +;;----------------------------------------------------- +;; function-max-args, function-min-args +;;----------------------------------------------------- +(defmacro check-function-argcounts (fun min max) + `(progn + (Assert (eq (function-min-args ,fun) ,min)) + (Assert (eq (function-max-args ,fun) ,max)))) + +(check-function-argcounts 'prog1 1 nil) ; special form +(check-function-argcounts 'command-execute 1 3) ; normal subr +(check-function-argcounts 'funcall 1 nil) ; `MANY' subr +(check-function-argcounts 'garbage-collect 0 0) ; no args subr + +;; Test interpreted and compiled functions +(loop for (arglist min max) in + '(((arg1 arg2 &rest args) 2 nil) + ((arg1 arg2 &optional arg3 arg4) 2 4) + ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) + (() 0 0)) + do + (eval + `(progn + (defun test-fun ,arglist nil) + (check-function-argcounts '(lambda ,arglist nil) ,min ,max) + (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) + +;;----------------------------------------------------- +;; Detection of cyclic variable indirection loops +;;----------------------------------------------------- +(fset 'test-sym1 'test-sym1) +(Check-Error cyclic-function-indirection (test-sym1)) + +(fset 'test-sym1 'test-sym2) +(fset 'test-sym2 'test-sym1) +(Check-Error cyclic-function-indirection (test-sym1)) +(fmakunbound 'test-sym1) ; else macroexpand-internal infloops! +(fmakunbound 'test-sym2) + +;;----------------------------------------------------- +;; Test `type-of' +;;----------------------------------------------------- +(Assert (eq (type-of load-path) 'cons)) +(Assert (eq (type-of obarray) 'vector)) +(Assert (eq (type-of 42) 'integer)) +(Assert (eq (type-of ?z) 'character)) +(Assert (eq (type-of "42") 'string)) +(Assert (eq (type-of 'foo) 'symbol)) +(Assert (eq (type-of (selected-device)) 'device)) diff --git a/tests/automated/test-harness.el b/tests/automated/test-harness.el new file mode 100644 index 0000000..a5c8b8a --- /dev/null +++ b/tests/automated/test-harness.el @@ -0,0 +1,367 @@ +;; test-harness.el --- Run Emacs Lisp test suites. + +;;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Keywords: testing + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;;; A test suite harness for testing XEmacs. +;;; The actual tests are in other files in this directory. +;;; Basically you just create files of emacs-lisp, and use the +;;; Assert, Check-Error, and Check-Message functions to create tests. +;;; You run the tests using M-x test-emacs-test-file, +;;; or $(EMACS) -l .../test-harness.el -f batch-test-emacs file ... +;;; which is run for you by the `make check' target in the top-level Makefile. + +(require 'bytecomp) + +(defvar test-harness-verbose + (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) + "*Non-nil means print messages describing progress of emacs-tester.") + +(defvar test-harness-current-file nil) + +(defvar emacs-lisp-file-regexp (purecopy "\\.el$") + "*Regexp which matches Emacs Lisp source files.") + +;;;###autoload +(defun test-emacs-test-file (filename) + "Test a file of Lisp code named FILENAME. +The output file's name is made by appending `c' to the end of FILENAME." + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (eq (cdr (assq 'major-mode (buffer-local-variables))) + 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name "Test file: " file-dir nil nil file-name)))) + ;; Expand now so we get the current buffer's defaults + (setq filename (expand-file-name filename)) + + ;; If we're testing a file that's in a buffer and is modified, offer + ;; to save it first. + (or noninteractive + (let ((b (get-file-buffer (expand-file-name filename)))) + (if (and b (buffer-modified-p b) + (y-or-n-p (format "save buffer %s first? " (buffer-name b)))) + (save-excursion (set-buffer b) (save-buffer))))) + + (if (or noninteractive test-harness-verbose) + (message "Testing %s..." filename)) + (let ((test-harness-current-file filename) + input-buffer) + (save-excursion + (setq input-buffer (get-buffer-create " *Test Input*")) + (set-buffer input-buffer) + (erase-buffer) + (insert-file-contents filename) + ;; Run hooks including the uncompression hook. + ;; If they change the file name, then change it for the output also. + (let ((buffer-file-name filename) + (default-major-mode 'emacs-lisp-mode) + (enable-local-eval nil)) + (normal-mode) + (setq filename buffer-file-name))) + (test-harness-from-buffer input-buffer filename) + (kill-buffer input-buffer) + )) + +(defun test-harness-read-from-buffer (buffer) + "Read forms from BUFFER, and turn it into a lambda test form." + (let ((body nil)) + (goto-char (point-min) buffer) + (condition-case error-info + (while t + (setq body (cons (read buffer) body))) + (end-of-file nil) + (error + (princ "Unexpected error %S reading forms from buffer\n" error-info))) + `(lambda () + (defvar passes) + (defvar assertion-failures) + (defvar no-error-failures) + (defvar wrong-error-failures) + (defvar missing-message-failures) + (defvar other-failures) + + (defvar unexpected-test-suite-failure) + (defvar trick-optimizer) + + ,@(nreverse body)))) + +(defun test-harness-from-buffer (inbuffer filename) + "Run tests in buffer INBUFFER, visiting FILENAME." + (defvar trick-optimizer) + (let ((passes 0) + (assertion-failures 0) + (no-error-failures 0) + (wrong-error-failures 0) + (missing-message-failures 0) + (other-failures 0) + + (trick-optimizer nil) + (unexpected-test-suite-failure nil) + (debug-on-error t)) + (with-output-to-temp-buffer "*Test-Log*" + + (defmacro Assert (assertion) + `(condition-case error-info + (progn + (assert ,assertion) + (princ (format "PASS: %S" (quote ,assertion))) + (terpri) + (incf passes)) + (cl-assertion-failed + (princ (format "FAIL: Assertion failed: %S\n" (quote ,assertion))) + (incf assertion-failures)) + (t (princ (format "FAIL: %S ==> error: %S\n" (quote ,assertion) error-info)) + (incf other-failures) + ))) + + (defmacro Check-Error (expected-error &rest body) + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) `(quote (progn ,@body))))) + `(condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (princ (format "FAIL: %S executed successfully, but expected error %S\n" + ,quoted-body + ',expected-error)) + (incf no-error-failures)) + (,expected-error + (princ (format "PASS: %S ==> error %S, as expected\n" + ,quoted-body ',expected-error)) + (incf passes)) + (error + (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n" + ,quoted-body ',expected-error error-info)) + (incf wrong-error-failures))))) + + (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) `(quote (progn ,@body))))) + `(condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (princ (format "FAIL: %S executed successfully, but expected error %S\n" + ,quoted-body + ',expected-error)) + (incf no-error-failures)) + (,expected-error + (let ((error-message (second error-info))) + (if (string-match ,expected-error-regexp error-message) + (progn + (princ (format "PASS: %S ==> error %S %S, as expected\n" + ,quoted-body error-message ',expected-error)) + (incf passes)) + (princ (format "FAIL: %S ==> got error %S as expected, but error message %S did not match regexp %S\n" + ,quoted-body ',expected-error error-message ,expected-error-regexp)) + (incf wrong-error-failures)))) + (error + (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n" + ,quoted-body ',expected-error error-info)) + (incf wrong-error-failures))))) + + + (defmacro Check-Message (expected-message-regexp &rest body) + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) `(quote (progn ,@body))))) + `(let ((messages "")) + (defadvice message (around collect activate) + (defvar messages) + (let ((msg-string (apply 'format (ad-get-args 0)))) + (setq messages (concat messages msg-string)) + msg-string)) + (condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (if (string-match ,expected-message-regexp messages) + (progn + (princ (format "PASS: %S ==> value %S, message %S, matching %S, as expected\n" + ,quoted-body trick-optimizer messages ',expected-message-regexp)) + (incf passes)) + (princ (format "FAIL: %S ==> value %S, message %S, NOT matching expected %S\n" + ,quoted-body trick-optimizer messages ',expected-message-regexp)) + (incf missing-message-failures))) + (error + (princ (format "FAIL: %S ==> unexpected error %S\n" + ,quoted-body error-info)) + (incf other-failures))) + (ad-unadvise 'message)))) + + (defmacro Ignore-Ebola (&rest body) + `(let ((debug-issue-ebola-notices -42)) ,@body)) + + (defun Int-to-Marker (pos) + (save-excursion + (set-buffer standard-output) + (save-excursion + (goto-char pos) + (point-marker)))) + + (princ "Testing Interpreted Lisp\n\n") + (condition-case error-info + (funcall (test-harness-read-from-buffer inbuffer)) + (error + (setq unexpected-test-suite-failure t) + (princ (format "Unexpected error %S while executing interpreted code\n" + error-info)) + (message "Unexpected error %S while executing interpreted code." error-info) + (message "Test suite execution aborted." error-info) + )) + (princ "\nTesting Compiled Lisp\n\n") + (let (code) + (condition-case error-info + (setq code (let ((byte-compile-warnings nil)) + (byte-compile (test-harness-read-from-buffer inbuffer)))) + (error + (princ (format "Unexpected error %S while byte-compiling code\n" + error-info)))) + (condition-case error-info + (if code (funcall code)) + (error + (princ (format "Unexpected error %S while executing byte-compiled code\n" + error-info)) + (message "Unexpected error %S while executing byte-compiled code." error-info) + (message "Test suite execution aborted." error-info) + ))) + (princ "\nSUMMARY:\n") + (princ (format "\t%5d passes\n" passes)) + (princ (format "\t%5d assertion failures\n" assertion-failures)) + (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) + (princ (format "\t%5d wrong-error failures\n" wrong-error-failures)) + (princ (format "\t%5d missing-message failures\n" missing-message-failures)) + (princ (format "\t%5d other failures\n" other-failures)) + (let* ((total (+ passes + assertion-failures + no-error-failures + wrong-error-failures + missing-message-failures + other-failures)) + (basename (file-name-nondirectory filename)) + (summary-msg + (if (> total 0) + (format "%s: %d of %d (%d%%) tests successful." + basename passes total (/ (* 100 passes) total)) + (format "%s: No tests run" basename)))) + (message "%s" summary-msg)) + (when unexpected-test-suite-failure + (message "Test suite execution failed unexpectedly.")) + (fmakunbound 'Assert) + (fmakunbound 'Check-Error) + (fmakunbound 'Ignore-Ebola) + (fmakunbound 'Int-to-Marker) + ))) + +(defvar test-harness-results-point-max nil) +(defmacro displaying-emacs-test-results (&rest body) + `(let ((test-harness-results-point-max test-harness-results-point-max)) + ;; Log the file name. + (test-harness-log-file) + ;; Record how much is logged now. + ;; We will display the log buffer if anything more is logged + ;; before the end of BODY. + (or test-harness-results-point-max + (save-excursion + (set-buffer (get-buffer-create "*Test-Log*")) + (setq test-harness-results-point-max (point-max)))) + (unwind-protect + (condition-case error-info + (progn ,@body) + (error + (test-harness-report-error error-info))) + (save-excursion + ;; If there were compilation warnings, display them. + (set-buffer "*Test-Log*") + (if (= test-harness-results-point-max (point-max)) + nil + (if temp-buffer-show-function + (let ((show-buffer (get-buffer-create "*Test-Log-Show*"))) + (save-excursion + (set-buffer show-buffer) + (setq buffer-read-only nil) + (erase-buffer)) + (copy-to-buffer show-buffer + (save-excursion + (goto-char test-harness-results-point-max) + (forward-line -1) + (point)) + (point-max)) + (funcall temp-buffer-show-function show-buffer)) + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char test-harness-results-point-max) + (recenter 1))))))))) + +(defun batch-test-emacs-1 (file) + (condition-case error-info + (progn (test-emacs-test-file file) t) + (error + (princ ">>Error occurred processing ") + (princ file) + (princ ": ") + (display-error error-info nil) + (terpri) + nil))) + +(defun batch-test-emacs () + "Run `test-harness' on the files remaining on the command line. +Use this from the command line, with `-batch'; +it won't work in an interactive Emacs. +Each file is processed even if an error occurred previously. +For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\"" + ;; command-line-args-left is what is left of the command line (from + ;; startup.el) + (defvar command-line-args-left) ;Avoid 'free variable' warning + (defvar debug-issue-ebola-notices) + (if (not noninteractive) + (error "`batch-test-emacs' is to be used only with -batch")) + (let ((error nil)) + (loop for file in command-line-args-left + do + (if (file-directory-p (expand-file-name file)) + (let ((files (directory-files file)) + source) + (while files + (if (and (string-match emacs-lisp-file-regexp (car files)) + (not (auto-save-file-name-p (car files))) + (setq source (expand-file-name + (car files) + file)) + (if (null (batch-test-emacs-1 source)) + (setq error t))) + (setq files (cdr files))))) + (if (null (batch-test-emacs-1 file)) + (setq error t)))) + ;;(message "%s" (buffer-string nil nil "*Test-Log*")) + (message "Done") + (kill-emacs (if error 1 0)))) + +(provide 'test-harness) + +;;; test-harness.el ends here diff --git a/version.sh b/version.sh index 6fd893a..097cc3e 100644 --- a/version.sh +++ b/version.sh @@ -1,8 +1,8 @@ #!/bin/sh emacs_major_version=21 emacs_minor_version=2 -emacs_beta_version=4 -xemacs_codename="Aglaophonos" +emacs_beta_version=5 +xemacs_codename="Aphrodite" infodock_major_version=4 infodock_minor_version=0 infodock_build_version=1 -- 1.7.10.4