included commits to RCS files with non-trunk default branches.
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.
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.
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 ;;
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
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 ;;
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
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 <stdlib.h>
+ #include <unistd.h>
+
+ 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}
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 ;;
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.
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
#! /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.
# 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
# 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 ]
;;
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
;;
-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
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.
amiga | amiga-*)
basic_machine=m68k-cbm
;;
- amigados)
+ amigaos | amigados)
basic_machine=m68k-cbm
- os=-amigados
+ os=-amigaos
;;
amigaunix | amix)
basic_machine=m68k-cbm
basic_machine=m68k-apple
os=-aux
;;
- aux)
- basic_machine=m68k-apple
- os=-aux
- ;;
balance)
basic_machine=ns32k-sequent
os=-dynix
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)
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/'`
;;
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
basic_machine=i386-sequent
os=-dynix
;;
+ tx39)
+ basic_machine=mipstx39-unknown
+ ;;
+ tx39el)
+ basic_machine=mipstx39el-unknown
+ ;;
tower | tower-32)
basic_machine=m68k-ncr
;;
basic_machine=vax-dec
os=-vms
;;
+ vpp*|vx|vx-*)
+ basic_machine=f301-fujitsu
+ ;;
vxworks960)
basic_machine=i960-wrs
os=-vxworks
# 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
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|'`
-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|'`
;;
sparc-* | *-sun)
os=-sunos4.1.1
;;
+ *-be)
+ os=-beos
+ ;;
*-ibm)
os=-aix
;;
os=-sysv
;;
*-cbm)
- os=-amigados
+ os=-amigaos
;;
*-dg)
os=-dgux
*-masscomp)
os=-rtu
;;
+ f301-fujitsu)
+ os=-uxpv
+ ;;
*)
os=-none
;;
-sunos*)
vendor=sun
;;
- -lynxos*)
- vendor=lynx
- ;;
-aix*)
vendor=ibm
;;
-ptx*)
vendor=sequent
;;
- -vxworks*)
+ -vxsim* | -vxworks*)
vendor=wrs
;;
-aux*)
vendor=apple
;;
- -aux*)
- vendor=apple
esac
basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
;;
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'.
--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)
--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.
--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.
--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.
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,
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
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
children of a base buffer.
\f
-* 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 ... <circular list>)
+
+An extra bonus is that checking for circularities is not just
+friendlier, but actually faster than checking for quit.
+
\f
* Changes in XEmacs 21.0
========================
** 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
*** \\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.
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.
\f
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.
** 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 <URL:http://www.umich.edu/~dirsvcs/ldap/>)
- LDAP SDK 1.0 from Netscape Corp.
(get it from <URL:http://developer.netscape.com/>)
+1998-12-05 XEmacs Build Bot <builds@cvs.xemacs.org>
+
+ * XEmacs 21.2.5 is released
+
1998-11-28 SL Baur <steve@altair.xemacs.org>
* XEmacs 21.2-beta4 is released.
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);
}
/*
- 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,
int
-main(argc,argv)
- int argc;
- char *argv[];
+main (int argc, char *argv[])
{
int chan; /* temporary channel number */
#ifdef SYSV_IPC
#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
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;
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")
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" ... )
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?
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
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")
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" ... )
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?
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
#include "getopt.h"
#ifdef MAIL_USE_POP
#include "pop.h"
-#include <regex.h>
+#include "../src/regex.h"
#endif
extern char *optarg;
/* 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;
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);
(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)
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
(prompts build-report-prompts))
(progn
(while prompts
+ (defvar hist)
(setq prompt (caar prompts))
(setq hist (cdar prompts))
(setq prompts (cdr prompts))
(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
-;;; 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.
;; 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
;; 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
;; 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?)
;; 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:
(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
(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.
;; 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 <x>) --> <x>
(if (cdr (cdr form))
;; 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.
(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)
;; 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
;; 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)
(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))
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
;; 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
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!
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)
(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))))
\f
(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
(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))))
(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.
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))
"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)
(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)
;;; Code:
+(eval-when-compile
+ (require 'obsolete))
(or (memq 'cl-19 features)
(error "Tried to load `cl-extra' before `cl'!"))
;; 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)
;; 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)))
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))
(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.
;;; 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.
(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))))))
(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))
(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))))
(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))))
(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
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))
(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)))
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))))
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)))
(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.
(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))))
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))
(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)
(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))
;; 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)))
(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)
(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)
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)))
(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)
(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)))
(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)
(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)
(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)))))
(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))
(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
(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.
(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))))
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)
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)
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)
;;; 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
;;; 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)
"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.
(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)))
;(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.
(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)
'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) ...),
"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
(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)
(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)
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
;;; 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) ...),
(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))))
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)))))
(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.
(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)))))
(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)))
"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)
;; 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
(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)
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)
(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.
(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."
;;; 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.
(defun disassemble-internal (obj indent interactive-p)
- (let ((macro 'nil)
- (name 'nil)
+ (let ((macro nil)
+ (name nil)
args)
(while (symbolp obj)
(setq name obj
(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
((eq (car-safe (car-safe arg)) 'byte-code)
(insert "(<byte code>...)\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
(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)
(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))
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)
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)
\f
;; 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
;;; 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 ?\ )
;; 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)
(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
"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"))))))
(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
(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)))
(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*")
;; - 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
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.
: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
(require 'cl)
(eval-and-compile
+ (defvar device-fonts-cache)
(condition-case ()
(require 'custom)
(error nil))
;; 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)
"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))
(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)))
(while (< i 255) ;; Oslash - Thorn
(aset table i (- i 32))
(setq i (1+ i)))
- table))
+ table))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utility functions
(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))))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)))))
(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))))
(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)
(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))))))
;;; 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 "^"
(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
;;; 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)
(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)))))
(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))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(?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)))
((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)
(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))
(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
(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.
"How often to blink faces"
:type 'number
:group 'faces)
-
+
(defun font-blink-initialize ()
(cond
((featurep 'itimer)
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)
;; 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.
: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)
(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))))
(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 ...)).")
;; ---------------------------------------------------------------------- ;;
;; ---------------------------------------------------------------------- ;;
-;; 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)
(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 "")
(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))
;; 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."
(".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") )
;; 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))
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))
(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")))
"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)
(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)
(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 ()
;; #### 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))
(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))
;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu>
;; 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.
;;
;;=== 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)
(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."
(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
;; 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")))
\f
;; This needs to be redone better. -slb
;;; 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)
;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)))
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)))
;;; 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 ()
;; 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)
(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)
;; 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)
(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)
;; 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.
nil
"-fc"
(mapconcat
- 'identity
+ #'identity
(append
(list (concat default-directory "../lib-src/make-docfile"))
options processed)
(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")))
("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 ", ")
" ")
"")
(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)
(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)
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
(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)
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)))))
\f
;;; Code:
(defgroup minibuffer nil
- "Controling the behaviour of the minibuffer."
+ "Controling the behavior of the minibuffer."
:group 'environment)
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:
(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
(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
;;; 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)
(alist #'(lambda ()
(mapcar #'(lambda (x)
(cons (substring x 0 (string-match "=" x))
- 'nil))
+ nil))
process-environment))))
(cond ((eq action 'lambda)
(concat "$" p)
(concat head "$" p)))
(all-completions env (funcall alist))))
- (t ;; 'nil
+ (t ;; nil
;; complete
(let* ((e (funcall alist))
(val (try-completion env e)))
;; 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)))
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)
(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
"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)
: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))
;; 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))
;; Delete empty directories.
(if dirs
(let ( (orig-default-directory default-directory)
- directory files file )
+; directory files file
+ )
;; Make sure we preserve the existing `default-directory'.
;; JV, why does this change the default directory? Does it indeed?
(unwind-protect
(mapcar
#'(lambda (reqd)
(let* ((reqd-package (package-get-package-provider reqd))
- (reqd-version (cadr reqd-package))
(reqd-name (car reqd-package)))
(if (null reqd-name)
(error "Unable to find a provider for %s" reqd))
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
(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.")
(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
;;; Code:
\f
+(defvar binary-process-output)
+(defvar buffer-file-type)
+
(defgroup processes nil
"Process, subshell, compilation, and job control support."
:group 'external
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.
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)))))
\f
(defun shell-command (command &optional output-buffer)
;; 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))))
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)
(buffer-substring (point)
(progn (end-of-line)
(point))))))
- (t
+ (t
(set-window-start (display-buffer buffer) 1))))))))
\f
;; 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
;; Thanks to Francesco Potorti` <pot@cnuce.cnr.it> 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:
\f
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))
(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
(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.
;; 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
(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)))
;; ?_)
(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)
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)
;; ---------------------------------------------------------------------------
;; 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])
;;; 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)
;;;
"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)
(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)
;; is compiled in).
;; Miscellaneous toolbar functions, useful for users to redefine, in
-;; order to get different behaviour.
+;; order to get different behavior.
;;; Code:
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
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
(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
;;; 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)
"\\<view-minor-mode-map>\\[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)
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:
;; 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)))
(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.
(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.
(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)
(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 ()
;; (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)
(define-key compose-map [?*] compose-ring-map)
\f
-;;; 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)
-;; )
-
-
-\f
;;; The contents of the "dead key" maps. These are shared by the
;;; compose-map.
(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)
(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
;; 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)))))
\f
;; 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)
(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
;; 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)
;; 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:
;; 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.
'((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)))
))))
((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...
(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))))
;;; 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
(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
;; 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)
RM = rm -f
AR = ar cq
-CC=@CC@
+CC=@XEMACS_CC@
CPP=@CPP@
CFLAGS=@CFLAGS@
CPPFLAGS=@CPPFLAGS@
/* 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),
#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);
print_widget_value (wv->next, 0, depth);
}
}
-#endif
+#endif /* SLOPPY_TYPES < 2 */
static Boolean
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
+1998-12-05 XEmacs Build Bot <builds@cvs.xemacs.org>
+
+ * XEmacs 21.2.5 is released
+
+1998-11-30 Martin Buchholz <martin@xemacs.org>
+
+ * 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 <steve@altair.xemacs.org>
* XEmacs 21.2-beta4 is released.
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}
@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
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}
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
@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
@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
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
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
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
(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
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.
@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
* Symbol::
* Marker::
* String::
-* Bytecode::
+* Compiled Function::
Events and the Event Loop
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
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
@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}.
@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
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
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
@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
@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
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
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).
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
(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
@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
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
@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:
[ 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
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
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
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
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;
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::
@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
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{<config.h>} (angle brackets so that
+Every module includes @file{<config.h>} (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
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
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;
@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}.
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
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
@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
@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
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
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
...
@{
/* 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.
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
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
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
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
@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.
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
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 <config.h>} first. Almost all .c
-files should @code{#include "lisp.h"} second.
+All @file{.c} files should @code{#include <config.h>} 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 <config.h> 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{<config.h>} 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
@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
@example
- 2347 paths.h
+paths.h
@end example
This is automatically generated from @file{paths.h.in} based on supplied
@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
@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
@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
@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
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()}.
@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
@example
- 2058 inline.c
+inline.c
@end example
This module is used in connection with inline functions (available in
@example
- 6489 debug.c
- 2267 debug.h
+debug.c
+debug.h
@end example
These functions provide a system for doing internal consistency checks
@example
- 1643 prefix-args.c
+prefix-args.c
@end example
This is actually the source for a small, self-contained program
@example
- 904 universe.h
+universe.h
@end example
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
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.
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
@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.
@example
- 64949 lread.c
+lread.c
@end example
This module implements the Lisp reader and the @code{read} function,
@example
- 40900 print.c
+print.c
@end example
This module implements the Lisp print mechanism and the @code{print}
@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
@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
@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.
@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
@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
@example
- 10975 marker.c
+marker.c
@end example
This module implements the @dfn{marker} Lisp object type, which
@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
@example
- 60155 editfns.c
+editfns.c
@end example
@file{editfns.c} contains the standard Lisp primitives for working with
@example
- 26081 callint.c
- 12577 cmds.c
- 2749 commands.h
+callint.c
+cmds.c
+commands.h
@end example
@cindex interactive
@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
@example
- 20476 doprnt.c
+doprnt.c
@end example
@file{doprnt.c} implements formatted-string processing, similar to
@example
- 15372 undo.c
+undo.c
@end example
This module implements the undo mechanism for tracking buffer changes.
@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
@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
@example
- 25212 keyboard.c
+keyboard.c
@end example
@file{keyboard.c} contains functions that implement the actual editor
@example
- 9973 macros.c
- 1397 macros.h
+macros.c
+macros.h
@end example
These two modules contain the basic code for defining keyboard macros.
@example
- 23234 minibuf.c
+minibuf.c
@end example
This contains some miscellaneous code related to the minibuffer (most of
@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
@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
@example
- 160783 window.c
- 15974 window.h
+window.c
+window.h
@end example
@cindex window (in Emacs)
@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.
@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.
@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
@example
- 14129 indent.c
+indent.c
@end example
This module contains various functions and Lisp primitives for
@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)
@example
- 10869 cm.c
- 5876 cm.h
+cm.c
+cm.h
@end example
These files provide some miscellaneous TTY-output functions and should
@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
@example
- 126926 fileio.c
+fileio.c
@end example
This implements the basic primitives for interfacing with the file
@example
- 10960 filelock.c
+filelock.c
@end example
This file provides functions for detecting clashes between different
@example
- 4527 filemode.c
+filemode.c
@end example
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
@example
- 4311 realpath.c
+realpath.c
@end example
This file provides an implementation of the @code{realpath()} function
@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
@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}
@example
- 49593 syntax.c
- 10200 syntax.h
+syntax.c
+syntax.h
@end example
@cindex scanner
@example
- 10438 casefiddle.c
+casefiddle.c
@end example
This module implements various Lisp primitives for upcasing, downcasing
@example
- 20234 rangetab.c
+rangetab.c
@end example
This module implements the @dfn{range table} Lisp object type, which
@example
- 3201 opaque.c
- 2206 opaque.h
+opaque.c
+opaque.h
@end example
This module implements the @dfn{opaque} Lisp object type, an
@example
- 8783 abbrev.c
+abbrev.c
@end example
This function provides a few primitives for doing dynamic abbreviation
@example
- 21934 doc.c
+doc.c
@end example
This function provides primitives for retrieving the documentation
@example
- 13197 md5.c
+md5.c
@end example
This function provides a Lisp primitive that implements the MD5 secure
@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
@example
- 136029 sysdep.c
- 5986 sysdep.h
+sysdep.c
+sysdep.h
@end example
These modules implement most of the low-level, messy operating-system
@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
@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
@example
- 44368 tooltalk.c
- 2137 tooltalk.h
+tooltalk.c
+tooltalk.h
@end example
These two modules implement an interface to the ToolTalk protocol, which
@example
- 22695 getloadavg.c
+getloadavg.c
@end example
This module provides the ability to retrieve the system's current load
@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
@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
@example
- 11669 hftctl.c
+hftctl.c
@end example
This module provides some terminal-control code necessary on versions of
@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
@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
@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.
@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
@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
@example
- 9673 xgccache.c
- 1111 xgccache.h
+xgccache.c
+xgccache.h
@end example
These modules provide functions for maintenance and caching of GC's
@example
- 69181 xselect.c
+xselect.c
@end example
@cindex selections
@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
@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
@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
-@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
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
@example
- 9400 intl.c
+intl.c
@end example
This provides some miscellaneous internationalization code for
@example
- 1764 iso-wide.h
+iso-wide.h
@end example
This contains leftover code from an earlier implementation of
* Symbol::
* Marker::
* String::
-* Bytecode::
+* Compiled Function::
@end menu
@node Introduction to Allocation
(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
@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
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.
@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. |
| | | | | |
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
|
|
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) |
V V
---->------------------------------------<----
|
- | [collected in
- | next_event_internal()]
+ | [collected in
+ | next_event_internal()]
|
unread- unread- event from |
command- command- keyboard else, call
@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_ |
-->----------<-- |
| |
| |
- dispatch Xt_what_callback()
+ dispatch Xt_what_callback()
event sets flags
queue |
| |
| |
| |
---->-----------<--------
- |
+ |
|
| [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
|
|
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) |
V V
---->----------------------------------<------
|
- | [collected in
- | next_event_internal()]
+ | [collected in
+ | next_event_internal()]
|
unread- unread- event from |
command- command- keyboard else, call
@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
@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
@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
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
@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.
@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:
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 <<
01110 not used
01111 not used
- 10000 <
- 10001 >
+ 10000 <
+ 10001 >
10010 ==
10011 <=
10100 >=
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
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.
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
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
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
@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
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
(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
@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{} #<compiled-function
-(from "loadup.el")
(n)
"...(23)"
[current-time-string t1 n 0]
@group
(silly-loop 5000000)
-@result{} ("Fri Nov 28 20:57:49 1997"
- "Fri Nov 28 20:57:55 1997") ; @r{6 seconds}
+@result{} ("Mon Sep 14 15:53:43 1998"
+ "Mon Sep 14 15:53:49 1998") ; @r{6 seconds}
@end group
@end example
- In this example, the interpreted code required 23 seconds to run,
+ In this example, the interpreted code required 18 seconds to run,
whereas the byte-compiled code required 6 seconds. These results are
representative, but actual results will vary greatly.
Normally, compiling a file does not evaluate the file's contents or
load the file. But it does execute any @code{require} calls at top
level in the file. One way to ensure that necessary macro definitions
-are available during compilation is to require the file that defines
+are available during compilation is to @code{require} the file that defines
them (@pxref{Named Features}). To avoid loading the macro definition files
when someone @emph{runs} the compiled program, write
@code{eval-when-compile} around the @code{require} calls (@pxref{Eval
@group
(byte-compile 'factorial)
@result{} #<compiled-function
-(from "loadup.el")
(integer)
"...(21)"
[integer 1 factorial]
@group
% ls -l push*
-rw-r--r-- 1 lewis 791 Oct 5 20:31 push.el
--rw-rw-rw- 1 lewis 638 Oct 8 20:25 push.elc
+-rw-r--r-- 1 lewis 638 Oct 8 20:25 push.elc
@end group
@end example
@end deffn
ignored. If it is non-@code{nil}, the user is asked whether to compile
each such file.
-The returned value of this command is unpredictable.
+The return value of this command is unpredictable.
@end deffn
@defun batch-byte-compile
@code{batch-byte-recompile-directory}.
@end defvar
-@defun byte-code code-string data-vector max-stack
+@defun byte-code instructions constants stack-size
@cindex byte-code interpreter
-This function actually interprets byte-code. A byte-compiled function
-is actually defined with a body that calls @code{byte-code}. Don't call
-this function yourself. Only the byte compiler knows how to generate
-valid calls to this function.
+This function actually interprets byte-code.
+Don't call this function yourself. Only the byte compiler knows how to
+generate valid calls to this function.
-In newer Emacs versions (19 and up), byte-code is usually executed as
+In newer Emacs versions (19 and up), byte code is usually executed as
part of a compiled-function object, and only rarely due to an explicit
-call to @code{byte-code}.
+call to @code{byte-code}. A byte-compiled function was once actually
+defined with a body that calls @code{byte-code}, but in recent versions
+of Emacs @code{byte-code} is only used to run isolated fragments of lisp
+code without an associated argument list.
@end defun
@node Docs and Compilation
occasionally if you edit and recompile Lisp files. When it happens, you
can cure the problem by reloading the file after recompiling it.
- Byte-compiled files made with Emacs 19.29 will not load into older
-versions because the older versions don't support this feature. You can
-turn off this feature by setting @code{byte-compile-dynamic-docstrings}
-to @code{nil}. Once this is done, you can compile files that will load
-into older Emacs versions. You can do this globally, or for one source
-file by specifying a file-local binding for the variable. Here's one
-way to do that:
+ Versions of Emacs up to and including XEmacs 19.14 and FSF Emacs 19.28
+do not support the dynamic docstrings feature, and so will not be able
+to load bytecode created by more recent Emacs versions. You can turn
+off the dynamic docstring feature by setting
+@code{byte-compile-dynamic-docstrings} to @code{nil}. Once this is
+done, you can compile files that will load into older Emacs versions.
+You can do this globally, or for one source file by specifying a
+file-local binding for the variable. Here's one way to do that:
@example
-*-byte-compile-dynamic-docstrings: nil;-*-
@cindex byte-code function
Byte-compiled functions have a special data type: they are
-@dfn{compiled-function objects}.
-
- A compiled-function object is a bit like a vector; however, 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{#<compiled-function} and ends 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}).
+@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{#<compiled-function} and ends 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
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
@code{backward-sexp}.
@example
-#<compiled-function
-(from "lisp.elc")
+(symbol-function 'backward-sexp)
+@result{} #<compiled-function
(&optional arg)
"...(15)" [arg 1 forward-sexp] 2 854740 "_p">
@end example
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,
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
@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
@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
; @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
(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
@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
; @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}
@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
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}.
@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
@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
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}.
@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.
@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
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}.)
@item
glyph
@item
-hashtable
+hash-table
@item
image-instance
@item
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:
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
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{} #<hashtable 0/71 0x313a>
+(make-hash-table :size 50)
+ @result{} #<hash-table 0/107 0x313a>
@end group
@end example
@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}.
@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},
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
@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 <arossini@@stat.sc.edu>
@author Ben Wing <wing@@666.com>
@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{<XEmacs
-libarary directory>/info/}. For example in
+library directory>/info/}. For example in
@file{/usr/local/lib/xemacs-20.4/info/}.
@end itemize
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
@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.
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
+1998-12-05 XEmacs Build Bot <builds@cvs.xemacs.org>
+
+ * XEmacs 21.2.5 is released
+
1998-11-28 SL Baur <steve@altair.xemacs.org>
* XEmacs 21.2-beta4 is released.
#include "faces.h"
#include "frame.h"
#include "toolbar.h"
-#include "redisplay.h"
#include "window.h"
static void EmacsFrameClassInitialize (void);
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},
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),
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)
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 */
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));
+ }
}
#include <config.h>
-#include <stdio.h>
+#include <assert.h>
#include <stdlib.h>
#include <X11/StringDefs.h>
#include "xintrinsicp.h"
#include <X11/Shell.h>
#include <X11/ShellP.h>
-#include <X11/Vendor.h>
-#include <X11/VendorP.h>
#include "EmacsShell.h"
#include "ExternalShell.h"
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
.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
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@
$(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\
## 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}
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
${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; \
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;
.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 $@
$(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; \
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)
#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
## 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
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
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
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..
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)
* 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)
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;
struct specbinding
{
- Lisp_Object symbol, old_value;
+ Lisp_Object symbol;
+ Lisp_Object old_value;
Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */
};
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. */
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_ */
#include <config.h>
#include <string.h>
-#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
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;
/* 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);
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);
/* 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.
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
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 <config.h>
#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 <stddef.h>
+#include <limits.h>
+
+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;
+\f
+
+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 */
\f
#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<<VALBITS)-1)) \
- METER_1 (this_code)++; \
- if (last_code \
- && METER_2 (last_code, this_code) != ((1<<VALBITS)-1))\
- METER_2 (last_code, this_code)++; \
- } \
-}
+#define METER_CODE(last_code, this_code) do { \
+ if (byte_metering_on) \
+ { \
+ if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
+ METER_1 (this_code)++; \
+ if (last_code \
+ && METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
+ METER_2 (last_code, this_code)++; \
+ } \
+} while (0)
-#endif /* no BYTE_CODE_METER */
-\f
+#endif /* BYTE_CODE_METER */
-Lisp_Object Qbyte_code;
-
-/* Byte codes: */
-
-#define Bvarref 010
-#define Bvarset 020
-#define Bvarbind 030
-#define Bcall 040
-#define Bunbind 050
-
-#define Bnth 070
-#define Bsymbolp 071
-#define Bconsp 072
-#define Bstringp 073
-#define Blistp 074
-#define Bold_eq 075
-#define Bold_memq 076
-#define Bnot 077
-#define Bcar 0100
-#define Bcdr 0101
-#define Bcons 0102
-#define Blist1 0103
-#define Blist2 0104
-#define Blist3 0105
-#define Blist4 0106
-#define Blength 0107
-#define Baref 0110
-#define Baset 0111
-#define Bsymbol_value 0112
-#define Bsymbol_function 0113
-#define Bset 0114
-#define Bfset 0115
-#define Bget 0116
-#define Bsubstring 0117
-#define Bconcat2 0120
-#define Bconcat3 0121
-#define Bconcat4 0122
-#define Bsub1 0123
-#define Badd1 0124
-#define Beqlsign 0125
-#define Bgtr 0126
-#define Blss 0127
-#define Bleq 0130
-#define Bgeq 0131
-#define Bdiff 0132
-#define Bnegate 0133
-#define Bplus 0134
-#define Bmax 0135
-#define Bmin 0136
-#define Bmult 0137
-
-#define Bpoint 0140
-#define Beq 0141 /* was Bmark, but no longer generated as of v18 */
-#define Bgoto_char 0142
-#define Binsert 0143
-#define Bpoint_max 0144
-#define Bpoint_min 0145
-#define Bchar_after 0146
-#define Bfollowing_char 0147
-#define Bpreceding_char 0150
-#define Bcurrent_column 0151
-#define Bindent_to 0152
-#define Bequal 0153 /* was Bscan_buffer, but no longer generated as of v18 */
-#define Beolp 0154
-#define Beobp 0155
-#define Bbolp 0156
-#define Bbobp 0157
-#define Bcurrent_buffer 0160
-#define Bset_buffer 0161
-#define Bsave_current_buffer 0162 /* was Bread_char, but no longer
- generated as of v19 */
-#define Bmemq 0163 /* was Bset_mark, but no longer generated as of v18 */
-#define Binteractive_p 0164 /* Needed since interactive-p takes unevalled args */
-
-#define Bforward_char 0165
-#define Bforward_word 0166
-#define Bskip_chars_forward 0167
-#define Bskip_chars_backward 0170
-#define Bforward_line 0171
-#define Bchar_syntax 0172
-#define Bbuffer_substring 0173
-#define Bdelete_region 0174
-#define Bnarrow_to_region 0175
-#define Bwiden 0176
-#define Bend_of_line 0177
-
-#define Bconstant2 0201
-#define Bgoto 0202
-#define Bgotoifnil 0203
-#define Bgotoifnonnil 0204
-#define Bgotoifnilelsepop 0205
-#define Bgotoifnonnilelsepop 0206
-#define Breturn 0207
-#define Bdiscard 0210
-#define Bdup 0211
-
-#define Bsave_excursion 0212
-#define Bsave_window_excursion 0213
-#define Bsave_restriction 0214
-#define Bcatch 0215
-
-#define Bunwind_protect 0216
-#define Bcondition_case 0217
-#define Btemp_output_buffer_setup 0220
-#define Btemp_output_buffer_show 0221
-
-#define Bunbind_all 0222
-
-#define Bset_marker 0223
-#define Bmatch_beginning 0224
-#define Bmatch_end 0225
-#define Bupcase 0226
-#define Bdowncase 0227
-
-#define Bstringeqlsign 0230
-#define Bstringlss 0231
-#define Bold_equal 0232
-#define Bnthcdr 0233
-#define Belt 0234
-#define Bold_member 0235
-#define Bold_assq 0236
-#define Bnreverse 0237
-#define Bsetcar 0240
-#define Bsetcdr 0241
-#define Bcar_safe 0242
-#define Bcdr_safe 0243
-#define Bnconc 0244
-#define Bquo 0245
-#define Brem 0246
-#define Bnumberp 0247
-#define Bintegerp 0250
-
-#define BRgoto 0252
-#define BRgotoifnil 0253
-#define BRgotoifnonnil 0254
-#define BRgotoifnilelsepop 0255
-#define BRgotoifnonnilelsepop 0256
-
-#define BlistN 0257
-#define BconcatN 0260
-#define BinsertN 0261
-#define Bmember 0266 /* new in v20 */
-#define Bassq 0267 /* new in v20 */
-
-#define Bconstant 0300
-#define CONSTANTLIM 0100
\f
-/* Fetch the next byte from the bytecode stream */
+static Lisp_Object
+bytecode_negate (Lisp_Object obj)
+{
+ retry:
-#define FETCH (massaged_code[pc++])
+#ifdef LISP_FLOAT_TYPE
+ if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
+#endif
+ if (CHARP (obj)) return make_int (- ((int) XCHAR (obj)));
+ if (MARKERP (obj)) return make_int (- ((int) marker_position (obj)));
+ if (INTP (obj)) return make_int (- XINT (obj));
-/* Fetch two bytes from the bytecode stream
- and make a 16-bit number out of them */
+ obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
+ goto retry;
+}
-#define FETCH2 (op = FETCH, op + (FETCH << 8))
+static Lisp_Object
+bytecode_nreverse (Lisp_Object list)
+{
+ REGISTER Lisp_Object prev = Qnil;
+ REGISTER Lisp_Object tail = list;
-/* Push x onto the execution stack. */
+ while (!NILP (tail))
+ {
+ REGISTER Lisp_Object next;
+ CHECK_CONS (tail);
+ next = XCDR (tail);
+ XCDR (tail) = prev;
+ prev = tail;
+ tail = next;
+ }
+ return prev;
+}
+
+
+/* We have our own two-argument versions of various arithmetic ops.
+ Only two-argument arithmetic operations have their own byte codes. */
+static int
+bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
+{
+ retry:
-#define PUSH(x) (*++stackp = (x))
+#ifdef LISP_FLOAT_TYPE
+ {
+ int ival1, ival2;
-/* Pop a value off the execution stack. */
+ if (INTP (obj1)) ival1 = XINT (obj1);
+ else if (CHARP (obj1)) ival1 = XCHAR (obj1);
+ else if (MARKERP (obj1)) ival1 = marker_position (obj1);
+ else goto arithcompare_float;
-#define POP (*stackp--)
+ if (INTP (obj2)) ival2 = XINT (obj2);
+ else if (CHARP (obj2)) ival2 = XCHAR (obj2);
+ else if (MARKERP (obj2)) ival2 = marker_position (obj2);
+ else goto arithcompare_float;
-/* Discard n values from the execution stack. */
+ return ival1 < ival2 ? -1 : ival1 > 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)));
+}
+
+\f
+/* 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<<VALBITS)-1))
- {
- XSETINT (v2, XINT (v2) + 1);
- Fput (v1, Qbyte_code_meter, v2);
- }
+ Lisp_Object val = Fget (TOP, Qbyte_code_meter, Qnil);
+ if (INTP (val))
+ Fput (TOP, Qbyte_code_meter, make_int (XINT (val) + 1));
}
-#endif /* BYTE_CODE_METER */
- TOP = Ffuncall (op + 1, &TOP);
+#endif
+ TOP = Ffuncall (n + 1, &TOP);
break;
+ case Bunbind:
+ case Bunbind+1:
+ case Bunbind+2:
+ case Bunbind+3:
+ case Bunbind+4:
+ case Bunbind+5:
case Bunbind+6:
- op = FETCH;
- goto dounbind;
-
case Bunbind+7:
- op = FETCH2;
- goto dounbind;
-
- case Bunbind: case Bunbind+1: case Bunbind+2: case Bunbind+3:
- case Bunbind+4: case Bunbind+5:
- op -= Bunbind;
- dounbind:
- unbind_to (specpdl_depth () - op, Qnil);
- break;
-
- case Bunbind_all:
- /* To unbind back to the beginning of this frame. Not used yet,
- but will be needed for tail-recursion elimination. */
- unbind_to (speccount, Qnil);
+ UNBIND_TO (specpdl_depth() -
+ (opcode < Bunbind+6 ? opcode-Bunbind :
+ opcode == Bunbind+6 ? READ_UINT_1 : READ_UINT_2));
break;
case Bgoto:
- QUIT;
- op = FETCH2; /* pc = FETCH2 loses since FETCH2 contains pc++ */
- pc = op;
+ JUMP;
break;
case Bgotoifnil:
- op = FETCH2;
if (NILP (POP))
- {
- QUIT;
- pc = op;
- }
+ JUMP;
+ else
+ JUMP_NEXT;
break;
case Bgotoifnonnil:
- op = FETCH2;
if (!NILP (POP))
- {
- QUIT;
- pc = op;
- }
+ JUMP;
+ else
+ JUMP_NEXT;
break;
case Bgotoifnilelsepop:
- op = FETCH2;
if (NILP (TOP))
+ JUMP;
+ else
{
- QUIT;
- pc = op;
+ DISCARD (1);
+ JUMP_NEXT;
}
- else DISCARD (1);
break;
case Bgotoifnonnilelsepop:
- op = FETCH2;
if (!NILP (TOP))
+ JUMP;
+ else
{
- QUIT;
- pc = op;
+ DISCARD (1);
+ JUMP_NEXT;
}
- else DISCARD (1);
break;
+
case BRgoto:
- QUIT;
- pc += massaged_code[pc] - 127;
+ JUMPR;
break;
case BRgotoifnil:
if (NILP (POP))
- {
- QUIT;
- pc += massaged_code[pc] - 128;
- }
- pc++;
+ JUMPR;
+ else
+ JUMPR_NEXT;
break;
case BRgotoifnonnil:
if (!NILP (POP))
- {
- QUIT;
- pc += massaged_code[pc] - 128;
- }
- pc++;
+ JUMPR;
+ else
+ JUMPR_NEXT;
break;
case BRgotoifnilelsepop:
- op = FETCH;
if (NILP (TOP))
+ JUMPR;
+ else
{
- QUIT;
- pc += op - 128;
+ DISCARD (1);
+ JUMPR_NEXT;
}
- else DISCARD (1);
break;
case BRgotoifnonnilelsepop:
- op = FETCH;
if (!NILP (TOP))
+ JUMPR;
+ else
{
- QUIT;
- pc += op - 128;
+ DISCARD (1);
+ JUMPR_NEXT;
}
- else DISCARD (1);
break;
case Breturn:
- v1 = POP;
- goto exit;
+ UNGCPRO;
+#ifdef ERROR_CHECK_BYTE_CODE
+ /* Binds and unbinds are supposed to be compiled balanced. */
+ if (specpdl_depth() != speccount)
+ invalid_byte_code_error ("unbalanced specbinding stack");
+#endif
+ return TOP;
case Bdiscard:
DISCARD (1);
break;
case Bdup:
- v1 = TOP;
- PUSH (v1);
- break;
+ {
+ Lisp_Object arg = TOP;
+ PUSH (arg);
+ break;
+ }
case Bconstant2:
- PUSH (vectorp[FETCH2]);
+ PUSH (constants_data[READ_UINT_2]);
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 Bsave_restriction:
- record_unwind_protect (save_restriction_restore,
- save_restriction_save ());
- break;
-
- case Bcatch:
- v1 = POP;
- TOP = internal_catch (TOP, Feval, v1, 0);
- break;
-
- case Bunwind_protect:
- record_unwind_protect (Fprogn, POP);
+ case Bcar:
+ TOP = CONSP (TOP) ? XCAR (TOP) : Fcar (TOP);
break;
- case Bcondition_case:
- v1 = POP; /* handlers */
- v2 = POP; /* bodyform */
- TOP = condition_case_3 (v2, TOP, v1);
+ case Bcdr:
+ TOP = CONSP (TOP) ? XCDR (TOP) : Fcdr (TOP);
break;
- case Btemp_output_buffer_setup:
- temp_output_buffer_setup ((char *) XSTRING_DATA (TOP));
- TOP = Vstandard_output;
- break;
- case Btemp_output_buffer_show:
- v1 = POP;
- temp_output_buffer_show (TOP, Qnil);
- TOP = v1;
- /* GAG ME!! */
- /* pop binding of standard-output */
- unbind_to (specpdl_depth() - 1, Qnil);
+ case Bunbind_all:
+ /* To unbind back to the beginning of this frame. Not used yet,
+ but will be needed for tail-recursion elimination. */
+ unbind_to (speccount, Qnil);
break;
case Bnth:
- v1 = POP;
- v2 = TOP;
- /* nth_entry: */
- CHECK_NATNUM (v2);
- for (op = XINT (v2); op; op--)
- {
- if (CONSP (v1))
- v1 = XCDR (v1);
- else if (NILP (v1))
- {
- TOP = Qnil;
- goto Bnth_done;
- }
- else
- {
- v1 = wrong_type_argument (Qlistp, v1);
- op++;
- }
- }
- goto docar;
- Bnth_done:
- break;
+ {
+ Lisp_Object arg = POP;
+ TOP = Fcar (Fnthcdr (TOP, arg));
+ break;
+ }
case Bsymbolp:
TOP = SYMBOLP (TOP) ? Qt : Qnil;
TOP = LISTP (TOP) ? Qt : Qnil;
break;
- case Beq:
- v1 = POP;
- TOP = EQ_WITH_EBOLA_NOTICE (v1, TOP) ? Qt : Qnil;
- break;
-
- case Bold_eq:
- v1 = POP;
- TOP = HACKEQ_UNSAFE (v1, TOP) ? Qt : Qnil;
+ case Bnumberp:
+ TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
break;
- case Bmemq:
- v1 = POP;
- TOP = Fmemq (TOP, v1);
+ case Bintegerp:
+ TOP = INTP (TOP) ? Qt : Qnil;
break;
- case Bold_memq:
- v1 = POP;
- TOP = Fold_memq (TOP, v1);
- break;
+ case Beq:
+ {
+ Lisp_Object arg = POP;
+ TOP = EQ_WITH_EBOLA_NOTICE (TOP, arg) ? Qt : Qnil;
+ break;
+ }
case Bnot:
TOP = NILP (TOP) ? Qt : Qnil;
break;
- case Bcar:
- v1 = TOP;
- docar:
- if (CONSP (v1)) TOP = XCAR (v1);
- else if (NILP (v1)) TOP = Qnil;
- else
- {
- TOP = wrong_type_argument (Qlistp, v1);
- goto docar;
- }
- break;
-
- case Bcdr:
- v1 = TOP;
- docdr:
- if (CONSP (v1)) TOP = XCDR (v1);
- else if (NILP (v1)) TOP = Qnil;
- else
- {
- TOP = wrong_type_argument (Qlistp, v1);
- goto docdr;
- }
- break;
-
case Bcons:
- v1 = POP;
- TOP = Fcons (TOP, v1);
- break;
+ {
+ Lisp_Object arg = POP;
+ TOP = Fcons (TOP, arg);
+ break;
+ }
case Blist1:
TOP = Fcons (TOP, Qnil);
break;
- case Blist2:
- v1 = POP;
- TOP = Fcons (TOP, Fcons (v1, Qnil));
- break;
- case Blist3:
- DISCARD (2);
- TOP = Flist (3, &TOP);
- break;
+ case BlistN:
+ n = READ_UINT_1;
+ goto do_list;
+ case Blist2:
+ case Blist3:
case Blist4:
- DISCARD (3);
- TOP = Flist (4, &TOP);
- break;
+ /* common case */
+ n = opcode - (Blist1 - 1);
+ do_list:
+ {
+ Lisp_Object list = Qnil;
+ list_loop:
+ list = Fcons (TOP, list);
+ if (--n)
+ {
+ DISCARD (1);
+ goto list_loop;
+ }
+ TOP = list;
+ break;
+ }
- case BlistN:
- op = FETCH;
- DISCARD (op - 1);
- TOP = Flist (op, &TOP);
+
+ case Bconcat2:
+ case Bconcat3:
+ case Bconcat4:
+ n = opcode - (Bconcat2 - 2);
+ goto do_concat;
+
+ case BconcatN:
+ /* common case */
+ n = READ_UINT_1;
+ do_concat:
+ DISCARD (n - 1);
+ TOP = Fconcat (n, &TOP);
break;
+
case Blength:
TOP = Flength (TOP);
break;
- case Baref:
- v1 = POP;
- TOP = Faref (TOP, v1);
- break;
-
case Baset:
- v2 = POP; v1 = POP;
- TOP = Faset (TOP, v1, v2);
- break;
+ {
+ Lisp_Object arg2 = POP;
+ Lisp_Object arg1 = POP;
+ TOP = Faset (TOP, arg1, arg2);
+ break;
+ }
case Bsymbol_value:
TOP = Fsymbol_value (TOP);
TOP = Fsymbol_function (TOP);
break;
- case Bset:
- v1 = POP;
- TOP = Fset (TOP, v1);
- break;
-
- case Bfset:
- v1 = POP;
- TOP = Ffset (TOP, v1);
- break;
-
case Bget:
- v1 = POP;
- TOP = Fget (TOP, v1, Qnil);
- break;
-
- case Bsubstring:
- v2 = POP; v1 = POP;
- TOP = Fsubstring (TOP, v1, v2);
- break;
-
- case Bconcat2:
- DISCARD (1);
- TOP = Fconcat (2, &TOP);
- break;
-
- case Bconcat3:
- DISCARD (2);
- TOP = Fconcat (3, &TOP);
- break;
-
- case Bconcat4:
- DISCARD (3);
- TOP = Fconcat (4, &TOP);
- break;
-
- case BconcatN:
- op = FETCH;
- DISCARD (op - 1);
- TOP = Fconcat (op, &TOP);
- break;
+ {
+ Lisp_Object arg = POP;
+ TOP = Fget (TOP, arg, Qnil);
+ break;
+ }
case Bsub1:
- v1 = TOP;
- if (INTP (v1))
- {
- XSETINT (v1, XINT (v1) - 1);
- TOP = v1;
- }
- else
- TOP = Fsub1 (v1);
+ TOP = INTP (TOP) ? make_int (XINT (TOP) - 1) : Fsub1 (TOP);
break;
case Badd1:
- v1 = TOP;
- if (INTP (v1))
- {
- XSETINT (v1, XINT (v1) + 1);
- TOP = v1;
- }
- else
- TOP = Fadd1 (v1);
+ TOP = INTP (TOP) ? make_int (XINT (TOP) + 1) : Fadd1 (TOP);
break;
+
case Beqlsign:
- v2 = POP; v1 = TOP;
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (v1);
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (v2);
-#ifdef LISP_FLOAT_TYPE
- if (FLOATP (v1) || FLOATP (v2))
- {
- double f1 = (FLOATP (v1) ? float_data (XFLOAT (v1)) : XINT (v1));
- double f2 = (FLOATP (v2) ? float_data (XFLOAT (v2)) : XINT (v2));
- TOP = (f1 == f2 ? Qt : Qnil);
- }
- else
-#endif /* LISP_FLOAT_TYPE */
- TOP = (XINT (v1) == XINT (v2) ? Qt : Qnil);
- break;
+ {
+ Lisp_Object arg = POP;
+ TOP = bytecode_arithcompare (TOP, arg) == 0 ? Qt : Qnil;
+ break;
+ }
case Bgtr:
- v1 = POP;
- TOP = arithcompare (TOP, v1, arith_grtr);
- break;
+ {
+ Lisp_Object arg = POP;
+ TOP = bytecode_arithcompare (TOP, arg) > 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;
+}
+
+\f
+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));
+}
+\f
+/************************************************************************/
+/* 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 ? "#[" : "#<compiled-function ", printcharfun);
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ if (!print_readably)
+ {
+ Lisp_Object ann = compiled_function_annotation (f);
+ 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 (compiled_function_arglist (f), printcharfun, escapeflag);
+
+ /* COMPILED_INSTRUCTIONS = 1 */
+ write_c_string (" ", printcharfun);
+ {
+ struct gcpro ngcpro1;
+ Lisp_Object instructions = compiled_function_instructions (f);
+ NGCPRO1 (instructions);
+ if (STRINGP (instructions) && !print_readably)
+ {
+ /* We don't usually want to see that junk in the bytecode. */
+ sprintf (buf, "\"...(%ld)\"",
+ (long) XSTRING_CHAR_LENGTH (instructions));
+ write_c_string (buf, printcharfun);
+ }
+ else
+ print_internal (instructions, printcharfun, escapeflag);
+ NUNGCPRO;
+ }
+
+ /* COMPILED_CONSTANTS = 2 */
+ write_c_string (" ", printcharfun);
+ print_internal (compiled_function_constants (f), printcharfun, escapeflag);
+
+ /* COMPILED_STACK_DEPTH = 3 */
+ sprintf (buf, " %d", compiled_function_stack_depth (f));
+ write_c_string (buf, printcharfun);
+
+ /* COMPILED_DOC_STRING = 4 */
+ if (docp || intp)
+ {
+ write_c_string (" ", printcharfun);
+ print_internal (compiled_function_documentation (f), printcharfun,
+ escapeflag);
+ }
+
+ /* COMPILED_INTERACTIVE = 5 */
+ if (intp)
+ {
+ write_c_string (" ", printcharfun);
+ print_internal (compiled_function_interactive (f), printcharfun,
+ escapeflag);
+ }
+
+ UNGCPRO;
+ 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);
+\f
+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;
+}
+
+\f
+
+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));
}
+\f
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
#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,
*/ );
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.
*/ );
{
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 */
}
#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 */
struct Lisp_Compiled_Function
{
struct lrecord_header lheader;
- unsigned short maxdepth;
+ unsigned short stack_depth;
+ unsigned short specpdl_depth;
struct
{
unsigned int documentationp: 1;
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. */
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
}
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;
{
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
struct gcpro gcpro1;
GCPRO1 (fun);
- fun = funcall_recording_as (function, 1, &fun);
+ fun = Ffuncall (1, &fun);
UNGCPRO;
}
if (set_zmacs_region_stays)
#include "commands.h"
#include "insdel.h"
#include "lstream.h"
-#include <paths.h>
#include "process.h"
#include "sysdep.h"
#include "window.h"
{
/* 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;
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);
\f
+/* 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.
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
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);
{
int fd;
for (fd=3; fd<=64; fd++)
- {
- close(fd);
- }
+ close (fd);
}
#endif /* not WINDOWSNT */
#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,
#include "commands.h"
#include "frame.h"
#include "events.h"
-#include "macros.h"
#include "window.h"
/* Current depth in recursive edits. */
/* 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
/* 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 */
/* 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;
#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)
#include "faces.h"
#include "frame.h"
#include "lstream.h"
-#include "redisplay.h"
#include "sysdep.h"
#include "sysfile.h"
#ifdef FILE_CODING
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
#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
{
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
{
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));
}
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, /*
#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)
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) \
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; \
}
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;
#include "objects-x.h"
#include "buffer.h"
+#include "elhash.h"
#include "events.h"
#include "faces.h"
#include "frame.h"
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;
XtNumber (emacs_options), &argc, argv);
speed_up_interrupts ();
- screen = DefaultScreen(dpy);
+ screen = DefaultScreen (dpy);
if (NILP (Vdefault_x_device))
Vdefault_x_device = device;
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) &&
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;
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 */
/* 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;
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);
}
\f
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
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, /*
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))
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,
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);
}
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);
}
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);
#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
{
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));
}
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;
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;
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);
{
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, /*
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.
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
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)
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.
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,
#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) \
#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))
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);
}
MakeMapObject (GifFile->Image.ColorMap->ColorCount,
GifFile->Image.ColorMap->Colors);
}
- sp->RasterBits = (GifPixelType *)NULL;
+ sp->RasterBits = NULL;
sp->ExtensionBlockCount = 0;
sp->ExtensionBlocks = (ExtensionBlock *)NULL;
}
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;
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,
* Miscellaneous utility functions *
******************************************************************************/
-int BitSize(int n)
+static int BitSize(int n)
/* return smallest bitfield size n will fit in */
{
register int i;
/* Synched up with: Not in FSF. */
-/* Autorship:
+/* Author:
Initially written by kkm, May 1998
*/
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
/*
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.
*/
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.
*/
#include "lisp.h"
#include "console-x.h"
-#include "EmacsManager.h"
#include "EmacsFrame.h"
-#include "EmacsShell.h"
#include "gui-x.h"
#include "buffer.h"
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)
while (1)
{
DIRENTRY *dp = readdir (d);
- Lisp_Object name;
int len;
if (!dp)
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);
}
\f
static Lisp_Object file_name_completion (Lisp_Object file,
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;
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;
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))
#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
{
weird_doc (sym, GETTEXT ("!CONSP(tem)"),
GETTEXT ("function"), pos);
- goto cont;
+ goto cont;
}
else
{
{
/* 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
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);
else
{
Lisp_Object old =
- compiled_function_documentation (b);
+ compiled_function_documentation (f);
if (!ZEROP (old))
{
weird_doc (sym, GETTEXT ("duplicate"),
if (!INTP (old))
goto weird;
}
- set_compiled_function_documentation (b, offset);
+ set_compiled_function_documentation (f, offset);
}
}
else
}
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);
}
This is a container object. Declare a dynamic array of a specific type
as follows:
-typdef struct
+typedef struct
{
Dynarr_declare (mytype);
} mytype_dynarr;
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)
/* 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. */
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)))
(buffer))
{
struct buffer *b = decode_buffer (buffer, 1);
-
return beginning_of_line_p (b, BUF_PT (b)) ? Qt : Qnil;
}
user_login_name (int *uid)
{
struct passwd *pw = NULL;
-
+
/* uid == NULL to return name of this user */
if (uid != NULL)
{
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;
{
#if defined(WINDOWSNT) && !defined(__CYGWIN32__)
char *homedrive, *homepath;
-
+
if ((homedrive = getenv("HOMEDRIVE")) != NULL &&
(homepath = getenv("HOMEPATH")) != NULL)
{
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. */
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. */
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);
}
*/
(int nargs, Lisp_Object *args))
{
- time_t _time;
+ time_t the_time;
struct tm tm;
Lisp_Object zone = (nargs > 6) ? args[nargs - 1] : Qnil;
if (CONSP (zone))
zone = XCAR (zone);
if (NILP (zone))
- _time = mktime (&tm);
+ the_time = mktime (&tm);
else
{
char tzbuf[100];
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;
#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, /*
-/* 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.
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.
#include <config.h>
#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];
}
+
\f
-/* 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);
+}
+
+\f
+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;
}
+\f
+/* 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;
}
\f
-/* 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),
If `print-readably' is non-nil, then a simpler syntax is used; for
instance:
- #<hashtable size 2/13 data (key1 value1 key2 value2) 0x874d>
+ #<hash-table size 2/13 data (key1 value1 key2 value2) 0x874d>
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" : "#<hashtable",
+ write_c_string (print_readably ? "#s(hash-table" : "#<hash-table",
printcharfun);
- if (table->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);
+}
+
\f
-/* 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))
{
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;
}
-\f
-/* 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 */
}
+\f
+/************************************************************************/
+/* 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.
-\f
+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 */
-
-\f
-
-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;
-}
+\f
+/************************************************************************/
+/* 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;
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)
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);
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;
}
#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_ */
/* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */
-/* Debugging hack */
-int always_gc;
-
-
#include <config.h>
#include "lisp.h"
#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
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
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;
/* 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;
*/
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 */
\f
-/**********************************************************************/
-/* 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) ? "#<special-form " : "#<subr ";
+ CONST char *name = subr_name (subr);
+ CONST char *trailer = subr->prompt ? " (interactive)>" : ">";
if (print_readably)
- error ("printing unreadable object #<subr %s>",
- subr_name (subr));
+ error ("printing unreadable object %s%s%s", header, name, trailer);
- write_c_string (((subr->max_args == UNEVALLED)
- ? "#<special-form "
- : "#<subr "),
- printcharfun);
-
- write_c_string (subr_name (subr), printcharfun);
- write_c_string (((subr->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);
-\f
-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);
\f
-/**********************************************************************/
-/* 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
}
/* 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.
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;
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);
&& 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);
&& !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))));
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);
: 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))));
}
\f
-/**********************************************************************/
-/* 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.
(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;
}
(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;
}
(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, /*
(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;
}
(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;
(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, /*
(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, /*
(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;
}
(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;
}
\f
-/**********************************************************************/
-/* 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.
(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, /*
(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, /*
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)))
{
{
/* 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)))
{
*/
(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, /*
}
\f
-/**********************************************************************/
-/* Non-local exits */
-/**********************************************************************/
+/************************************************************************/
+/* Non-local exits */
+/************************************************************************/
DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /*
\(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'.
(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.
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
backtrace_list = c->backlist;
lisp_eval_depth = c->lisp_eval_depth;
+#if 0 /* no longer used */
throw_level = 0;
+#endif
LONGJMP (c->jmp, 1);
}
(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)));
}
\f
-/**********************************************************************/
-/* Signalling and trapping errors */
-/**********************************************************************/
+/************************************************************************/
+/* Signalling and trapping errors */
+/************************************************************************/
static Lisp_Object
condition_bind_unwind (Lisp_Object loser)
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;
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
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);
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.
(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, /*
(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
/* (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
extern int in_display;
\f
-/****************** the workhorse error-signaling function ******************/
+/************************************************************************/
+/* the workhorse error-signaling function */
+/************************************************************************/
/* #### This function has not been synched with FSF. It diverges
significantly. */
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
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.
}
\f
-/**********************************************************************/
-/* 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));
+}
+\f
+/************************************************************************/
+/* User commands */
+/************************************************************************/
DEFUN ("commandp", Fcommandp, 1, 1, 0, /*
Return t if FUNCTION makes provisions for interactive calling.
{
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, /*
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);
}
\f
-/**********************************************************************/
-/* Autoloading */
-/**********************************************************************/
+/************************************************************************/
+/* Autoloading */
+/************************************************************************/
DEFUN ("autoload", Fautoload, 2, 5, 0, /*
Define FUNCTION to autoload from FILE.
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)
{
Vautoload_queue = oldqueue;
while (CONSP (queue))
{
- first = Fcar (queue);
+ first = XCAR (queue);
second = Fcdr (first);
first = Fcar (first);
if (NILP (second))
Lisp_Object funname)
{
/* This function can GC */
- int speccount = specpdl_depth_counter;
+ int speccount = specpdl_depth();
Lisp_Object fun = funname;
struct gcpro gcpro1, gcpro2;
/* 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. */
}
\f
-/**********************************************************************/
-/* 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
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.
*/
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);
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)
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;
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)
}
\f
-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)
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);
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);
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:
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);
}
\f
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 '()) */
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
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);
}
\f
-/* 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));
}
+
\f
-/**********************************************************************/
-/* 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.
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. */
}
else
{
+ struct gcpro gcpro1, gcpro2;
GCPRO2 (sym, val);
for (;
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))
}
\f
-/**********************************************************************/
-/* Front-ends to eval, funcall, apply */
-/**********************************************************************/
+/************************************************************************/
+/* Front-ends to eval, funcall, apply */
+/************************************************************************/
/* Apply fn to arg */
Lisp_Object
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);
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);
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);
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);
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);
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);
}
\f
-/***** 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
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;
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);
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;
}
GCPRO2 (opaque, function);
- speccount = specpdl_depth_counter;
+ speccount = specpdl_depth();
specbind (Qinhibit_quit, Qt);
/* gc_currently_forbidden = 1; Currently no reason to do this; */
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;
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;
}
\f
-/**********************************************************************/
-/* 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();
}
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);
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;
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
/* 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;
-}
\f
/* Get the value of symbol's global binding, even if that binding is
#endif /* 0 */
\f
-/**********************************************************************/
-/* Backtraces */
-/**********************************************************************/
+/************************************************************************/
+/* Backtraces */
+/************************************************************************/
DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /*
Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
/* 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;
}
\f
-/**********************************************************************/
-/* Warnings */
-/**********************************************************************/
+/************************************************************************/
+/* Warnings */
+/************************************************************************/
void
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
\f
-/**********************************************************************/
-/* Initialization */
-/**********************************************************************/
+/************************************************************************/
+/* Initialization */
+/************************************************************************/
void
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);
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);
/* 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 ();
}
#include "blocktype.h"
#include "buffer.h"
-#include "commands.h"
#include "console.h"
#include "console-tty.h"
#include "events.h"
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)
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,
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);
}
}
{
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);
}
}
}
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);
/* simple_p means don't try too hard (ASCII only) */
{
KeySym keysym = 0;
-
+
#ifdef HAVE_XIM
int len;
char buffer[64];
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;
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;
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)) );
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;
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) =
struct Xt_timeout *timeout, *t2;
timeout = NULL;
-
+
/* Find the timeout on the list of pending ones, if it's still there. */
if (pending_timeouts)
{
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.
/* 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
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)
{
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);
}
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 */
* 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.
* 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
}
/*
- * 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).
*
{
if (errno != EINTR)
{
- /* something bad happended */
+ /* something bad happened */
assert(0);
}
}
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)
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];
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;
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)))
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.
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.
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
/* 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;
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;
}
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);
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 */
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;
}
* 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);
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
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)
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 */
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))
/* 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
;
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
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;
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.
(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
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:
default:
abort ();
}
- ((markobj) (event->channel));
+ markobj (event->channel);
return event->next;
}
print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
if (print_readably)
- error ("printing unreadable object #<event>");
+ error ("Printing unreadable object #<event>");
switch (XEVENT (obj)->event_type)
{
}
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);
#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 */
}
case empty_event: /* Empty and deallocated events are equal. */
case dead_event:
return 1;
-
- default:
- abort ();
- return 0; /* not reached; warning suppression */
}
}
}
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;
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))
{
}
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);
/* 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();
}
}
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;
}
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;
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-");
switch (e->event_type)
{
+ default: abort ();
+
case process_event:
props = cons3 (Qprocess, e->event.process.process, props);
break;
case empty_event:
RETURN_UNGCPRO (Qnil);
break;
-
- default:
- abort ();
- break; /* not reached; warning suppression */
}
props = cons3 (Qchannel, Fevent_channel (event), props);
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
------------------------
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
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.
*/
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;
/* 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);
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,
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);
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[];
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,
#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 */
#include "faces.h"
#include "frame.h"
#include "glyphs.h"
-#include "hash.h"
#include "insdel.h"
#include "keymap.h"
#include "opaque.h"
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,
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;
}
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
(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++)
Lisp_Object exobj;
XSETEXTENT (exobj, extent);
- ((markobj) (exobj));
+ markobj (exobj);
}
}
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;
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. */
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
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;
}
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);
{
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;
}
write_c_string (" ", printcharfun);
}
- sprintf (buf, "0x%lx", (unsigned long int) ext);
+ sprintf (buf, "0x%lx", (long) ext);
write_c_string (buf, printcharfun);
}
if (!EXTENT_LIVE_P (XEXTENT (obj)))
error ("printing unreadable object #<destroyed extent>");
else
- error ("printing unreadable object #<extent 0x%p>",
- XEXTENT (obj));
+ error ("printing unreadable object #<extent 0x%lx>",
+ (long) XEXTENT (obj));
}
if (!EXTENT_LIVE_P (XEXTENT (obj)))
}
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));
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
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 */
}
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))
{
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))
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);
!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;
{
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;
}
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
** 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);
/* 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;
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);
}
#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))
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--;
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--;
/* 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);
}
\f
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. */
}
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;
{
/* 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()). */
}
#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));
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));
/* 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 */
/* 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
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 */
*/
(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
*/
(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
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));
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
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 */
*/
(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 */
}
*/
(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
*/
(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 */
*/
(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));
}
#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);
#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;
*/
(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, /*
*/
(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));
}
\f
/* Float-rounding functions. */
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
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 ();
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
}
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);
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;
}
\f
/************************************************************************/
-/* initialization */
+/* initialization */
/************************************************************************/
void
int need_delete = 1;
int need_focus = 1;
- if (!XtIsWMShell (widget))
- abort ();
+ assert (XtIsWMShell (widget));
{
Atom type, *atoms = 0;
{
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);
}
numItems++;
item = XCDR (item);
}
-
+
if (numItems)
{
/*
*/
Ctext = (char *)xmalloc (textlen+1);
Ctext[0] = 0;
-
+
item = dragdata;
while (!NILP (item))
{
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;
}
UNGCPRO;
-
+
return numItems?Qt:Qnil;
}
/* 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 );
}
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 */,
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;
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))
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. */
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. */
#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 */
#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;
DtDND_FILENAME_TRANSFER | DtDND_BUFFER_TRANSFER,
XmDROP_COPY, dnd_transfer_cb_rec,
DtNtextIsBuffer, True,
- DtNregisterChildren, True,
+ DtNregisterChildren, True,
DtNpreserveRegistration, False,
NULL);
}
* 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
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
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);
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))
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
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
#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)
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;
/* 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;
#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
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 <config.h>
#include "lisp.h"
#else
/* 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);
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 {
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;
#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;
#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;
int line;
blocktype type;
int value;
-#ifdef SAVE_STACK
- fun_entry backtrace[TRACE_LIMIT];
-#endif
};
typedef struct block_input_history_struct block_input_history;
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;
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;
__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.
}
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);
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;
/* This is the in-core version of an extension record */
typedef struct {
- int ByteCount;
+ int ByteCount;
GifByteType *Bytes; /* on malloc(3) heap */
} ExtensionBlock;
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
break;
case XpmFileInvalid:
{
- signal_simple_error ("invalid XPM data", image);
+ signal_simple_error ("Invalid XPM data", image);
}
case XpmNoMemory:
{
}
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,
LR_SHARED |
(!NILP (file) ? LR_LOADFROMFILE : 0))))
{
- signal_simple_error ("cannot load image", instantiator);
+ signal_simple_error ("Cannot load image", instantiator);
}
if (hinst)
/*
- * 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
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];
(depth > 8) ? 16 :
8);
byte_cnt = bitmap_pad >> 3;
-
+
outimg = XCreateImage (dpy, vis,
depth, ZPixmap, 0, 0, width, height,
bitmap_pad, 0);
return NULL;
}
outimg->data = (char *) data;
-
+
if (vis->class == PseudoColor)
{
unsigned long pixarray[256];
{
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;
#endif
}
}
- }
+ }
return outimg;
}
}
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. */
/* reset the dynarr */
Lstream_rewind(ostr);
}
-
+
if (fclose (tmpfil) != 0)
fubar = 1;
Lstream_close (istr);
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)
unsigned long *pixtbl = NULL;
int npixels = 0;
XImage* ximage;
-
+
ximage = convert_EImage_to_XImage (device, width, height, eimage,
&pixtbl, &npixels);
if (!ximage)
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,
}
}
-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);
}
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;
/* 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
#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
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,
#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
#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 *
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. */
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 ]
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];
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;
|| 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);
}
}
#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 (
#include <config.h>
#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;
#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,
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)
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;
}
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)
{
}
/* 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)
{
}
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;
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_ */
/* 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 */
(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*/
/* 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.
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);
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:
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
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:
#include "buffer.h"
#include "bytecode.h"
-#include "commands.h"
#include "console.h"
#include "elhash.h"
#include "events.h"
*/
-struct keymap
+typedef struct Lisp_Keymap
{
struct lcrecord_header header;
Lisp_Object parents; /* Keymaps to be searched after this one
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)
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;
}
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)
/* No need for keymap_equal #### Why not? */
DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap,
mark_keymap, print_keymap, 0, 0, 0,
- struct keymap);
+ Lisp_Keymap);
\f
/************************************************************************/
/* Traversing keymaps and their parents */
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)
}
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
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);
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);
{
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)
};
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;
}
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 */
{
/************************************************************************/
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;
}
};
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.
*/
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;
}
/* #### 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);
}
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;
}
else
{
- signal_simple_error ("unknown key-sequence specifier",
+ signal_simple_error ("Unknown key-sequence specifier",
spec);
}
}
{
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;
? 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
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)
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) &&
* 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)
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.
{
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
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.
*/
/* 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;
}
struct key_data key;
key.keysym = keysym;
key.modifiers = modifiers;
- ((*closure->fn) (&key, contents, closure->arg));
+ ((*closure->fn) (&key, value, closure->arg));
}
return 0;
}
/* 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;
}
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);
#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);
}
}
}
-/* 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').
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)))
{
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))
#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)
#include <config.h>
#include "lisp.h"
#include "buffer.h"
-#include "insdel.h"
#include "line-number.h"
/* 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)
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 */
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; }
#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);
Lstream *lstr = XLSTREAM (obj);
char buf[200];
- sprintf (buf, "#<INTERNAL EMACS BUG (%s lstream) 0x%p>",
- lstr->imp->name, lstr);
+ sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s lstream) 0x%lx>",
+ lstr->imp->name, (long) lstr);
write_c_string (buf, printcharfun);
}
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;
}
die $usage if @ARGV;
($srcdir = $0) =~ s@[^/]+$@@;
+$srcdir = "." if $srcdir eq "";
chdir $srcdir or die "$srcdir: $!";
opendir SRCDIR, "." or die "$srcdir: $!";
#include <sys/resource.h>
#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 */
}
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
(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);
{
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;
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;
#endif
#include <sys/types.h>
-
-#include <stdlib.h>
#include <string.h>
-
#include <stdio.h>
#if defined HAVE_LIMITS_H || _LIBC
/* 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
* 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!
*
/* 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.
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! */
/*
* 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)
/*
* 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.
* 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
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;
{
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)
/* 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);
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));
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));
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))
/* 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);
}
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 */
/* 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;
}
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;
}
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);
static void
mswindows_free_frame_menubars (struct frame* f)
{
- FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil;
+ FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil;
}
static void
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 */
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);
}
/* Synched up with: Not in FSF. */
-/* Autorship:
+/* Author:
Initially written by kkm 12/24/97,
*/
#include "lisp.h"
#include "console-x.h"
-#include "EmacsManager.h"
#include "EmacsFrame.h"
-#include "EmacsShell.h"
#include "gui-x.h"
#include "buffer.h"
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);
/* 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)
if (active_spec)
active_p = Feval (active_p);
-
+
if (!NILP (hook_fn) && !NILP (active_p))
{
#if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF
/* 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;
}
}
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;
{
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;
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:
}
-/* 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. */
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
/* 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));
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 */
:label <form> (unimplemented!) Like :suffix, but replaces label
completely.
(might be added in 21.2).
-
+
For example:
("File"
}
-/* #### 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? */
#ifdef emacs
#include <config.h>
#include "lisp.h"
+#include "sysdep.h"
+#include "syssignal.h"
#endif
-#if __STDC__ || defined (STDC_HEADERS)
-# include <stdlib.h>
-# include <stdarg.h>
-# include <string.h>
-#endif
+#include <stdlib.h>
+#include <stdarg.h>
+#include <string.h>
+#include <stdio.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
-#include <stdio.h>
-#include "syssignal.h"
#undef LITTLE_ENDIAN
#undef BIG_ENDIAN
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! */
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 ();
}
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;
*/
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;
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 */
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
/* 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;
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
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.
#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. */
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)'.
"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;
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
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);
}
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;
}
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;
}
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
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
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.
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.
*/
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.) */
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));
}
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
{
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));
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);
}
{
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
so we can freely error. */
Lisp_Object device = DFW_DEVICE (domain);
struct device *d = XDEVICE (device);
- Lisp_Object instance;
if (COLOR_INSTANCEP (instantiator))
{
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))
{
{
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
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))
{
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;
{
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
}
/*================================================================== 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)
#include <config.h>
#include "lisp.h"
#include "opaque.h"
+#include <stddef.h>
Lisp_Object Qopaquep;
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, "#<INTERNAL EMACS BUG (opaque, size=%ld) 0x%lx>",
- (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, "#<INTERNAL EMACS BUG (opaque, freed) 0x%lx>",
- (unsigned long) XPNTR (obj));
+ sprintf (size_buf, "freed");
+
+ sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (opaque, %s) 0x%lx>",
+ 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! */
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! */
{
#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;
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))
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));
(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
#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)
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)
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))
#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)));
#include "lstream.h"
#include "sysfile.h"
+#include <limits.h>
#include <float.h>
/* Define if not in float.h */
#ifndef DBL_DIG
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. */
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;
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;
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);
}
}
}
void
-temp_output_buffer_setup (CONST char *bufname)
+temp_output_buffer_setup (Lisp_Object bufname)
{
/* This function can GC */
struct buffer *old = current_buffer;
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);
}
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)
GCPRO3 (buf, arg, same_frame);
- temp_output_buffer_setup (GETTEXT (bufname));
+ temp_output_buffer_setup (bufname);
buf = Vstandard_output;
arg = (*function) (arg);
(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));
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 ("... <circular list>", 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))
print_internal (obj, printcharfun, escapeflag);
}
UNGCPRO;
+
write_char_internal (")", printcharfun);
return;
}
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
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) ? "#[" :
- "#<compiled-function "),
- ((print_readably) ? "]" : ">"),
- obj, printcharfun, escapeflag);
-}
#ifdef LISP_FLOAT_TYPE
void
{
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 */
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;
}
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);
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;
}
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
-/* 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.
/* 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;
}
/*
- * Initialize XEmacs process implemenation once
+ * Initialize XEmacs process implementation once
*/
static void
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.
*/
}
/*
- * 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
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)
-/* 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.
#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"
/*
- * Implemenation-specific data. Pointed to by Lisp_Process->process_data
+ * Implementation-specific data. Pointed to by Lisp_Process->process_data
*/
struct unix_process_data
#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)
}
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 */
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
* 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.
*/
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)
{
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);
}
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;
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)
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)
#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;
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;
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));
}
* 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
/*
* 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
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.
/* 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. */
#include "opaque.h"
#include "process.h"
#include "procimpl.h"
-#include "sysdep.h"
#include "window.h"
#ifdef FILE_CODING
#include "file-coding.h"
/* 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;
{
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;
}
/************************************************************************/
/* 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,
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;
}
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
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. */
handle_signal (SIGUNUSED);
#endif
#ifdef SIGDANGER
- handle_signal (SIGDANGER);
+ handle_signal (SIGDANGER); /* AIX */
#endif
#ifdef SIGMSG
handle_signal (SIGMSG);
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
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
/*
* 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.
*/
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;
#include "backtrace.h"
#include "bytecode.h"
+#include "elhash.h"
#include "hash.h"
#include "syssignal.h"
(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;
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))
{
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;
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
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;
}
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.
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;
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
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;
}
(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_);
}
/*
** 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:/...
#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
/* 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
/* 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 <dkindred+@cmu.edu>.
/* 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 <dkindred+@cmu.edu>.
#include "console-x.h"
#include "glyphs-x.h"
-#include "EmacsFrame.h"
-#include "EmacsManager.h"
#include "gui-x.h"
#include "scrollbar-x.h"
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;
}
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)
{
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;
}
/* 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)
{
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
\f
static struct scrollbar_instance *
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
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
/* 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)
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) \
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);
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.
*/
())
{
#include "console-x.h"
#endif
-#include "commands.h"
#include "device.h"
#include "redisplay.h"
#include "sysdep.h"
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.
{
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;
!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;
}
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;
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;
/* 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
CHECK_SPECIFIER (specifier);
check_modifiable_specifier (specifier);
-
+
locale = decode_locale (locale);
check_valid_instantiator (instantiator,
decode_specifier_type
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)
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);
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));
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;
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.
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
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.
*/
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().
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;
/* 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 *****/
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;
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.);
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);
};
#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);
/* 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 }
{ 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_ */
}
#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)
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 */
#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)
/* <mdiers> ### This is not portable. ###
POSIX does not specify CBAUD, and 4.4BSD does not have it.
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
}
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
/* limits of text/data segments */
/************************************************************************/
-/* Note that VMS compiler won't accept defined (CANNOT_DUMP). */
#ifndef CANNOT_DUMP
#define NEED_STARTS
#endif
* 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.
*
*/
{
int rtnval;
while ((rtnval = open (path, oflag, mode)) == -1
- && (errno == EINTR));
+ && (errno == EINTR))
+ DO_NOTHING;
return rtnval;
}
#else
#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
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;
{
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 */
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 */
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 */
/* 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);
#include <config.h>
#endif
-#include <stdlib.h>
-#include <assert.h>
-#include <string.h>
-#include <stdio.h>
#include "sysdll.h"
/* This whole file is conditional upon HAVE_DLL */
#include <direct.h>
#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
#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. */
#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
#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)
#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)
\f
/* Include the proper files. */
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#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. */
#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). */
/* ----------------------------------------------------- */
/* 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 */
\f
/* ----------------------------------------------------- */
/* 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);
}
{
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);
}
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
{
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 */
nbuttons, nbuttons * 2 )))
{
xfree (button_tbl);
- signal_simple_error ("couldn't create image list",
+ signal_simple_error ("Couldn't create image list",
instance);
}
}
Fputhash (make_int (tbbutton->idCommand),
- button, FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f));
+ button, FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f));
}
/* now fix up the button size */
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))
{
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;
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;
}
/* 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)
}
}
-#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;
}
{
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);
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;
}
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
{
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;
}
&& !EQ (val, Q3D)
&& !EQ (val, Q2d)
&& !EQ (val, Q3d))
- CTB_ERROR ("unrecognized toolbar blank style");
+ CTB_ERROR ("Unrecognized toolbar blank style");
return Q_style;
}
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;
}
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;
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;
}
#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) \
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;
};
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;
}
error ("printing unreadable object #<tooltalk_message 0x%x>",
p->header.uid);
- sprintf (buf, "#<tooltalk_message id:%p 0x%x>", p->m, p->header.uid);
+ sprintf (buf, "#<tooltalk_message id:0x%lx 0x%x>", (long) (p->m), p->header.uid);
write_c_string (buf, printcharfun);
}
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;
}
error ("printing unreadable object #<tooltalk_pattern 0x%x>",
p->header.uid);
- sprintf (buf, "#<tooltalk_pattern id:%p 0x%x>", p->p, p->header.uid);
+ sprintf (buf, "#<tooltalk_pattern id:0x%lx 0x%x>", (long) (p->p), p->header.uid);
write_c_string (buf, printcharfun);
}
(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;
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;
}
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);
}
(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.
(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.
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
# include <stdlib.h>
# include <unistd.h>
# include <string.h>
+# include <stddef.h>
# ifdef __lucid
# include <sysent.h>
#ifdef __STDC__
#ifndef __sys_stdtypes_h
-#ifndef _PTRDIFF_T
+#if !defined(_PTRDIFF_T) && !defined(_BSD_PTRDIFF_T_)
typedef long ptrdiff_t;
#endif
#endif
#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
#include <config.h>
#include "lisp.h"
#include "buffer.h"
-#include "insdel.h"
Lisp_Object Qwidget_type;
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))
{
*/
(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));
#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;
\f
#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;
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;
}
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))
/* 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)
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));
/* 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
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;
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;
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))
{
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);
\f
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))
}
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))
}
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))
}
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))
(*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. */
}
/* 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
}
\f
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.
}
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
}
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
}
\f
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));
}
\f
DEFUN ("center-to-window-line", Fcenter_to_window_line, 0, 2, "_P", /*
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),
{
int v = map_windows_1 (FRAME_ROOT_WINDOW (XFRAME (XCAR (frmcons))),
mapfun, closure);
- if (v)
+ if (v)
return v;
}
}
}
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);
{
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
}
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.
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);
#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.
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.
struct gc_cache_cell *head;
struct gc_cache_cell *tail;
#ifdef GCCACHE_HASH
- c_hashtable table;
+ struct hash_table *table;
#endif
int create_count;
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;
}
rest = next;
}
#ifdef GCCACHE_HASH
- free_hashtable (cache->table);
+ free_hash_table (cache->table);
#endif
xfree (cache);
}
\f
#ifdef DEBUG_XEMACS
-#include <stdio.h>
-
void describe_gc_cache (struct gc_cache *cache);
void
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");
/*
- * Based on an optimized version provided by Jim Becker, Auguest 5, 1988.
+ * Based on an optimized version provided by Jim Becker, August 5, 1988.
*/
/*
* 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)
{
--- /dev/null
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Martin Buchholz <martin@xemacs.org>
+;; Maintainer: Martin Buchholz <martin@xemacs.org>
+;; 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)))
+
--- /dev/null
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Martin Buchholz <martin@xemacs.org>
+;; Maintainer: Martin Buchholz <martin@xemacs.org>
+;; 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))))
+ ))
--- /dev/null
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Martin Buchholz <martin@xemacs.org>
+;; Maintainer: Martin Buchholz <martin@xemacs.org>
+;; 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))
+ )
--- /dev/null
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Martin Buchholz <martin@xemacs.org>
+;; Maintainer: Martin Buchholz <martin@xemacs.org>
+;; 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))
--- /dev/null
+;; 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
#!/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