-*- indented-text -*-
+to 21.2 beta5 "Aphrodite"
+-- bytecode interpreter rewritten
+-- byte compiler fixes
+-- hash table implementation rewritten
+-- basic lisp functions rewritten
+-- spelling fixes
+-- garbage collector tuned a little
+-- various global code changes for consistency
+-- automated test suite
+-- major internals manual updates
+-- lisp reference updates
+
to 21.2 beta4 "Aglaophonos"
-- isearch keymap fix from Katsumi Yamaoka
-- directory_files cleanup from Hrvoje Niksic
+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.
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/"`
;;
case "$opt" in
- run_in_place | \
- with_site_lisp | \
+ with_site_lisp | \
with_x | \
with_x11 | \
with_msw | \
with_gcc | \
- with_gnu_make | \
dynamic | \
with_ncurses | \
with_dnet | \
with_tiff | \
with_session | \
with_xmu | \
+ with_purify | \
with_quantify | \
with_toolbars | \
with_tty | \
with_xfs | \
with_i18n3 | \
with_mule | \
- with_file_coding | \
+ with_file_coding| \
with_canna | \
with_wnn | \
with_wnn6 | \
with_workshop | \
with_sparcworks | \
- with_tooltalk | \
+ with_tooltalk | \
with_ldap | \
with_pop | \
with_kerberos | \
verbose | \
extra_verbose | \
const_is_losing | \
- usage_tracking | \
- use_union_type | \
+ usage_tracking | \
+ use_union_type | \
debug | \
use_assertions | \
+ gung_ho | \
use_minimal_tagbits | \
use_indexed_lrecord_implementation | \
- gung_ho | \
- use_assertions | \
memory_usage_stats | \
with_clash_detection | \
with_shlib | \
no_doc_file )
case "$val" in
y | ye | yes ) val=yes ;;
- n | no ) val=no ;;
+ n | no ) val=no ;;
* ) (echo "$progname: Usage error:"
echo " " "The \`--$optname' option requires a boolean value: \`yes' or \`no'."
echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;;
esac
- eval "$opt=\"$val\"" ;;
+ eval "$opt=\"$val\"" ;;
srcdir | \
ldflags | \
puresize | \
cache_file | \
- native_sound_lib | \
+ native_sound_lib| \
site_lisp | \
x_includes | \
x_libraries | \
* ) (echo "$progname: Usage error:"
echo " " "The \`--$optname' option value
must be either \`no' or a comma-separated list
- of one or more of \`berkdb', \`dbm', or \`gnudbm'."
+ of one or more of \`berkdb' and either \`dbm' or \`gnudbm'."
echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;;
esac
done
eval "$opt=\"$val\""
;;
- "with_xfs" )
- case "$val" in
- y | ye | yes ) val=yes ;;
- n | no | non | none ) val=no ;;
- * ) (echo "$progname: Usage error:"
-echo " " "The \`--$optname' option must have one of these values:
- \`yes', or \`no'."
-echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;;
- esac
- eval "$opt=\"$val\""
- ;;
-
"mail_locking" )
case "$val" in
lockf ) val=lockf ;;
prefix | exec_prefix | bindir | datadir | statedir | libdir | \
mandir | infodir | infopath | lispdir | etcdir | lockdir | pkgdir | \
- archlibdir | docdir | package_path )
+ archlibdir | docdir | package_path )
if test "$valomitted" = "yes"; then
if test "$#" = 0; then
(echo "$progname: Usage error:"
"usage" | "help" ) ${PAGER-more} ${srcdir}/configure.usage; exit 0 ;;
- "with_menubars" | "with_scrollbars" | "with_dialogs" )
+ "with_menubars" | \
+ "with_scrollbars" | \
+ "with_dialogs" )
case "$val" in
l | lu | luc | luci | lucid ) val=lucid ;;
m | mo | mot | moti | motif ) val=motif ;;
eval "$opt=\"$val\""
;;
+ "run_in_place" | \
+ "with_gnu_make" )
+ echo "configure: warning: Obsolete option \`--$optname' ignored." 1>&2
+ ;;
+
* ) (echo "$progname: Usage error:"
echo " " "Unrecognized option: $arg"
echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;;
test "$extra_verbose" = "yes" && verbose=yes
-case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac
-case "$site_libraries" in *:* ) site_libraries="`echo '' $site_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac
-case "$site_prefixes" in *:* ) site_prefixes="`echo '' $site_prefixes | sed -e 's/^ //' -e 's/:/ /g'`";; esac
-case "$site_runtime_libraries" in *:* ) site_runtime_libraries="`echo '' $site_runtime_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac
-
test -n "$with_x" && with_x11="$with_x"
+if test "$with_purify" = "yes" -o "$with_quantify" = "yes"; then
+ test "$with_system_malloc" = "default" && with_system_malloc=yes
+fi
if test -n "$gung_ho"; then
test -z "$use_minimal_tagbits" && use_minimal_tagbits="$gung_ho"
fi
-if test "$run_in_place" = "yes"; then
- echo "configure: warning: "The --run-in-place option is ignored because it is unnecessary."" 1>&2
-fi
-
case "$srcdir" in
"" )
esac
if test -z "$configuration"; then
- echo $ac_n "checking "host system type"""... $ac_c" 1>&6
-echo "configure:759: checking "host system type"" >&5
- if configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess | \
- sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` ; then
- echo "$ac_t""$configuration" 1>&6
- else
- echo "$ac_t""unknown" 1>&6
+ configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess`
+ if test -z "$configuration"; then
(echo "$progname: Usage error:"
echo " " "XEmacs has not been ported to this host type.
Try explicitly specifying the CONFIGURATION when rerunning configure."
fi
echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6
-echo "configure:773: checking whether ln -s works" >&5
+echo "configure:755: checking whether ln -s works" >&5
rm -f conftestdata
if ln -s X conftestdata 2>/dev/null
-echo "checking "the configuration name"" 1>&6
-echo "configure:989: checking "the configuration name"" >&5
+echo $ac_n "checking "host system type"""... $ac_c" 1>&6
+echo "configure:971: checking "host system type"" >&5
internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'`
-if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else
- exit $?
-fi
+canonical=`${CONFIG_SHELL-/bin/sh} $srcdir/config.sub "$internal_configuration"`
+configuration=`echo "$configuration" | sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'`
+canonical=`echo "$canonical" | sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'`
+echo "$ac_t""$configuration" 1>&6
m68*-sony-* ) machine=news ;;
mips-sony-* ) machine=news-risc ;;
clipper-* ) machine=clipper ;;
+ arm-* ) machine=arm ;;
+ ns32k-* ) machine=ns32000 ;;
esac
case "$canonical" in
*-*-openbsd* )
case "${canonical}" in
- alpha*-*-openbsd*) machine=alpha ;;
i386-*-openbsd*) machine=intel386 ;;
m68k-*-openbsd*) machine=hp9000s300 ;;
mipsel-*-openbsd*) machine=pmax ;;
- ns32k-*-openbsd*) machine=ns32000 ;;
- sparc-*-openbsd*) machine=sparc ;;
- vax-*-openbsd*) machine=vax ;;
esac
;;
m68k-*-linux* ) machine=m68k opsys=linux ;;
- arm-*-linux* ) machine=arm opsys=linux ;;
-
esac
if test -z "$machine" -o -z "$opsys"; then
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1481: checking for $ac_word" >&5
+echo "configure:1460: checking for $ac_word" >&5
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1507: checking for $ac_word" >&5
+echo "configure:1486: checking for $ac_word" >&5
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
-echo "configure:1552: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+echo "configure:1531: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
ac_ext=c
xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS'
cross_compiling=no
cat > conftest.$ac_ext <<EOF
-#line 1564 "configure"
+#line 1543 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-if { (eval echo configure:1568: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:1547: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
-echo "configure:1588: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "configure:1567: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:1593: checking whether we are using GNU C" >&5
+echo "configure:1572: checking whether we are using GNU C" >&5
cat > conftest.c <<EOF
#ifdef __GNUC__
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1600: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1579: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:1614: checking whether ${CC-cc} accepts -g" >&5
+echo "configure:1593: checking whether ${CC-cc} accepts -g" >&5
echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1643: checking for $ac_word" >&5
+echo "configure:1622: checking for $ac_word" >&5
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1669: checking for $ac_word" >&5
+echo "configure:1648: checking for $ac_word" >&5
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
-echo "configure:1714: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+echo "configure:1693: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
ac_ext=c
xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS'
cross_compiling=no
cat > conftest.$ac_ext <<EOF
-#line 1726 "configure"
+#line 1705 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-if { (eval echo configure:1730: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:1709: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
-echo "configure:1750: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "configure:1729: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:1755: checking whether we are using GNU C" >&5
+echo "configure:1734: checking whether we are using GNU C" >&5
cat > conftest.c <<EOF
#ifdef __GNUC__
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1762: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1741: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:1776: checking whether ${CC-cc} accepts -g" >&5
+echo "configure:1755: checking whether ${CC-cc} accepts -g" >&5
echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1805: checking for $ac_word" >&5
+echo "configure:1784: checking for $ac_word" >&5
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1831: checking for $ac_word" >&5
+echo "configure:1810: checking for $ac_word" >&5
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
-echo "configure:1876: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+echo "configure:1855: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
ac_ext=c
xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS'
cross_compiling=no
cat > conftest.$ac_ext <<EOF
-#line 1888 "configure"
+#line 1867 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-if { (eval echo configure:1892: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:1871: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
-echo "configure:1912: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "configure:1891: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:1917: checking whether we are using GNU C" >&5
+echo "configure:1896: checking whether we are using GNU C" >&5
cat > conftest.c <<EOF
#ifdef __GNUC__
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1924: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1903: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:1938: checking whether ${CC-cc} accepts -g" >&5
+echo "configure:1917: checking whether ${CC-cc} accepts -g" >&5
echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
test -n "$NON_GNU_CPP" -a "$GCC" != "yes" -a -z "$CPP" && CPP="$NON_GNU_CPP"
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
-echo "configure:1971: checking how to run the C preprocessor" >&5
+echo "configure:1950: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
-#line 1984 "configure"
+#line 1963 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1990: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1969: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
:
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 2001 "configure"
+#line 1980 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2007: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1986: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
:
echo $ac_n "checking for AIX""... $ac_c" 1>&6
-echo "configure:2030: checking for AIX" >&5
+echo "configure:2009: checking for AIX" >&5
cat > conftest.$ac_ext <<EOF
-#line 2032 "configure"
+#line 2011 "configure"
#include "confdefs.h"
#ifdef _AIX
yes
echo $ac_n "checking for GNU libc""... $ac_c" 1>&6
-echo "configure:2059: checking for GNU libc" >&5
+echo "configure:2038: checking for GNU libc" >&5
cat > conftest.$ac_ext <<EOF
-#line 2061 "configure"
+#line 2040 "configure"
#include "confdefs.h"
#include <features.h>
int main() {
; return 0; }
EOF
-if { (eval echo configure:2073: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:2052: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
have_glibc=yes
else
cat > conftest.$ac_ext <<EOF
-#line 2095 "configure"
+#line 2074 "configure"
#include "confdefs.h"
int main () {
#if defined __SUNPRO_C
#endif
}
EOF
-if { (eval echo configure:2107: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:2086: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
:
else
EOF
-CPP=`eval "echo $CPP"`
+CPP=`eval "echo $CPP $CPPFLAGS"`
eval `$CPP -Isrc $tempcname \
| sed -n -e "s/[ ]*=[ \"]*/='/" -e "s/[ \"]*\$/'/" -e "s/^configure___//p"`
set x $ld_switch_system; shift; ld_switch_system=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) ld_switch_system="$ld_switch_system $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) ld_switch_system="$ld_switch_system $1" ;;
+ -L | -l | -u ) ld_switch_system="$ld_switch_system $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) ld_switch_system="$ld_switch_system $1" ;;
-Xlinker* ) ;;
* ) ld_switch_system="$ld_switch_system -Xlinker $1" ;;
esac
set x $ld_switch_machine; shift; ld_switch_machine=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) ld_switch_machine="$ld_switch_machine $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) ld_switch_machine="$ld_switch_machine $1" ;;
+ -L | -l | -u ) ld_switch_machine="$ld_switch_machine $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) ld_switch_machine="$ld_switch_machine $1" ;;
-Xlinker* ) ;;
* ) ld_switch_machine="$ld_switch_machine -Xlinker $1" ;;
esac
set x $LDFLAGS; shift; LDFLAGS=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) LDFLAGS="$LDFLAGS $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) LDFLAGS="$LDFLAGS $1" ;;
+ -L | -l | -u ) LDFLAGS="$LDFLAGS $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) LDFLAGS="$LDFLAGS $1" ;;
-Xlinker* ) ;;
* ) LDFLAGS="$LDFLAGS -Xlinker $1" ;;
esac
set x $ld_call_shared; shift; ld_call_shared=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) ld_call_shared="$ld_call_shared $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) ld_call_shared="$ld_call_shared $1" ;;
+ -L | -l | -u ) ld_call_shared="$ld_call_shared $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) ld_call_shared="$ld_call_shared $1" ;;
-Xlinker* ) ;;
* ) ld_call_shared="$ld_call_shared -Xlinker $1" ;;
esac
fi
echo $ac_n "checking for dynodump""... $ac_c" 1>&6
-echo "configure:2377: checking for dynodump" >&5
+echo "configure:2356: checking for dynodump" >&5
if test "$unexec" != "unexsol2.o"; then
echo "$ac_t""no" 1>&6
else
done
echo $ac_n "checking for terminateAndUnload in -lC""... $ac_c" 1>&6
-echo "configure:2415: checking for terminateAndUnload in -lC" >&5
+echo "configure:2394: checking for terminateAndUnload in -lC" >&5
ac_lib_var=`echo C'_'terminateAndUnload | sed 'y%./+-%__p_%'`
xe_check_libs=" -lC "
cat > conftest.$ac_ext <<EOF
-#line 2420 "configure"
+#line 2399 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
terminateAndUnload()
; return 0; }
EOF
-if { (eval echo configure:2431: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:2410: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
-if test -n "$site_prefixes"; then
- for arg in $site_prefixes; do
- case "$arg" in
- -* ) ;;
- * ) argi="-I${arg}/include" ; argl="-L${arg}/lib" ;;
- esac
- c_switch_site="$c_switch_site $argi" && if test "$extra_verbose" = "yes"; then echo " Appending \"$argi\" to \$c_switch_site"; fi
- ld_switch_site="$ld_switch_site $argl" && if test "$extra_verbose" = "yes"; then echo " Appending \"$argl\" to \$ld_switch_site"; fi
- done
-fi
-
+case "$site_libraries" in *:* ) site_libraries="`echo '' $site_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac
if test -n "$site_libraries"; then
for arg in $site_libraries; do
- case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac
+ case "$arg" in
+ -* ) ;;
+ * ) test -d "$arg" || \
+ { echo "Invalid site library \`$arg': no such directory" >&2; exit 1; }
+ arg="-L${arg}" ;;
+ esac
ld_switch_site="$ld_switch_site $arg" && if test "$extra_verbose" = "yes"; then echo " Appending \"$arg\" to \$ld_switch_site"; fi
done
fi
+case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac
if test -n "$site_includes"; then
for arg in $site_includes; do
- case "$arg" in -* ) ;; * ) arg="-I${arg}" ;; esac
+ case "$arg" in
+ -* ) ;;
+ * ) test -d "$arg" || \
+ { echo "Invalid site include \`$arg': no such directory" >&2; exit 1; }
+ arg="-I${arg}" ;;
+ esac
c_switch_site="$c_switch_site $arg" && if test "$extra_verbose" = "yes"; then echo " Appending \"$arg\" to \$c_switch_site"; fi
done
fi
+case "$site_prefixes" in *:* ) site_prefixes="`echo '' $site_prefixes | sed -e 's/^ //' -e 's/:/ /g'`";; esac
+if test -n "$site_prefixes"; then
+ for dir in $site_prefixes; do
+ inc_dir="${dir}/include"
+ lib_dir="${dir}/lib"
+ if test ! -d "$dir"; then
+ { echo "Invalid site prefix \`$dir': no such directory" >&2; exit 1; }
+ elif test ! -d "$inc_dir"; then
+ { echo "Invalid site prefix \`$dir': no such directory \`$inc_dir'" >&2; exit 1; }
+ elif test ! -d "$lib_dir"; then
+ { echo "Invalid site prefix \`$dir': no such directory \`$lib_dir'" >&2; exit 1; }
+ else
+ c_switch_site="$c_switch_site "-I$inc_dir"" && if test "$extra_verbose" = "yes"; then echo " Appending \""-I$inc_dir"\" to \$c_switch_site"; fi
+ ld_switch_site="$ld_switch_site "-L$lib_dir"" && if test "$extra_verbose" = "yes"; then echo " Appending \""-L$lib_dir"\" to \$ld_switch_site"; fi
+ fi
+ done
+fi
+
for dir in "/usr/ccs/lib"; do
test -d "$dir" && ld_switch_site="$ld_switch_site -L${dir}" && if test "$extra_verbose" = "yes"; then echo " Appending \"-L${dir}\" to \$ld_switch_site"; fi
done
+case "$site_runtime_libraries" in *:* ) site_runtime_libraries="`echo '' $site_runtime_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac
if test -n "$site_runtime_libraries"; then
LD_RUN_PATH="`echo $site_runtime_libraries | sed -e 's/ */:/g'`"
export LD_RUN_PATH
if test "$add_runtime_path" = "yes"; then
echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6
-echo "configure:2515: checking "for runtime libraries flag"" >&5
+echo "configure:2514: checking "for runtime libraries flag"" >&5
case "$opsys" in
sol2 ) dash_r="-R" ;;
decosf* | linux* ) dash_r="-rpath " ;;
set x $xe_check_libs; shift; xe_check_libs=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) xe_check_libs="$xe_check_libs $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) xe_check_libs="$xe_check_libs $1" ;;
+ -L | -l | -u ) xe_check_libs="$xe_check_libs $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) xe_check_libs="$xe_check_libs $1" ;;
-Xlinker* ) ;;
* ) xe_check_libs="$xe_check_libs -Xlinker $1" ;;
esac
done
fi
cat > conftest.$ac_ext <<EOF
-#line 2537 "configure"
+#line 2536 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
-if { (eval echo configure:2544: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:2543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
dash_r="$try_dash_r"
else
set x $ld_switch_run; shift; ld_switch_run=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;;
+ -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;;
-Xlinker* ) ;;
* ) ld_switch_run="$ld_switch_run -Xlinker $1" ;;
esac
fi
after_morecore_hook_exists=yes
echo $ac_n "checking for malloc_get_state""... $ac_c" 1>&6
-echo "configure:2645: checking for malloc_get_state" >&5
+echo "configure:2644: checking for malloc_get_state" >&5
cat > conftest.$ac_ext <<EOF
-#line 2648 "configure"
+#line 2647 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char malloc_get_state(); below. */
; return 0; }
EOF
-if { (eval echo configure:2671: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:2670: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_malloc_get_state=yes"
else
fi
echo $ac_n "checking for malloc_set_state""... $ac_c" 1>&6
-echo "configure:2691: checking for malloc_set_state" >&5
+echo "configure:2690: checking for malloc_set_state" >&5
cat > conftest.$ac_ext <<EOF
-#line 2694 "configure"
+#line 2693 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char malloc_set_state(); below. */
; return 0; }
EOF
-if { (eval echo configure:2717: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:2716: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_malloc_set_state=yes"
else
fi
echo $ac_n "checking whether __after_morecore_hook exists""... $ac_c" 1>&6
-echo "configure:2737: checking whether __after_morecore_hook exists" >&5
+echo "configure:2736: checking whether __after_morecore_hook exists" >&5
cat > conftest.$ac_ext <<EOF
-#line 2739 "configure"
+#line 2738 "configure"
#include "confdefs.h"
extern void (* __after_morecore_hook)();
int main() {
__after_morecore_hook = 0
; return 0; }
EOF
-if { (eval echo configure:2746: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:2745: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
else
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:2805: checking for $ac_word" >&5
+echo "configure:2804: checking for $ac_word" >&5
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
# ./install, which can be erroneously created by make from ./install.sh.
echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
-echo "configure:2858: checking for a BSD compatible install" >&5
+echo "configure:2857: checking for a BSD compatible install" >&5
if test -z "$INSTALL"; then
IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:"
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:2909: checking for $ac_word" >&5
+echo "configure:2908: checking for $ac_word" >&5
if test -n "$YACC"; then
ac_cv_prog_YACC="$YACC" # Let the user override the test.
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:2940: checking for $ac_hdr" >&5
+echo "configure:2939: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 2943 "configure"
+#line 2942 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2948: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2947: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:2981: checking for $ac_hdr" >&5
+echo "configure:2980: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 2984 "configure"
+#line 2983 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2989: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2988: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
fi
done
-for ac_hdr in linux/version.h kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h
+for ac_hdr in kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:3022: checking for $ac_hdr" >&5
+echo "configure:3021: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 3025 "configure"
+#line 3024 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:3030: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3029: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
done
echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6
-echo "configure:3060: checking for sys/wait.h that is POSIX.1 compatible" >&5
+echo "configure:3059: checking for sys/wait.h that is POSIX.1 compatible" >&5
cat > conftest.$ac_ext <<EOF
-#line 3063 "configure"
+#line 3062 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/wait.h>
s = WIFEXITED (s) ? WEXITSTATUS (s) : 1;
; return 0; }
EOF
-if { (eval echo configure:3079: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3078: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_sys_wait_h=yes
else
fi
echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
-echo "configure:3103: checking for ANSI C header files" >&5
+echo "configure:3102: checking for ANSI C header files" >&5
cat > conftest.$ac_ext <<EOF
-#line 3106 "configure"
+#line 3105 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:3114: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3113: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
if test $ac_cv_header_stdc = yes; then
# SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 3131 "configure"
+#line 3130 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if test $ac_cv_header_stdc = yes; then
# ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 3149 "configure"
+#line 3148 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if test $ac_cv_header_stdc = yes; then
# /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
cat > conftest.$ac_ext <<EOF
-#line 3167 "configure"
+#line 3166 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
exit (0); }
EOF
-if { (eval echo configure:3178: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:3177: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
:
else
fi
echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
-echo "configure:3204: checking whether time.h and sys/time.h may both be included" >&5
+echo "configure:3203: checking whether time.h and sys/time.h may both be included" >&5
cat > conftest.$ac_ext <<EOF
-#line 3207 "configure"
+#line 3206 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
struct tm *tp;
; return 0; }
EOF
-if { (eval echo configure:3216: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3215: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_time=yes
else
fi
echo $ac_n "checking for sys_siglist declaration in signal.h or unistd.h""... $ac_c" 1>&6
-echo "configure:3240: checking for sys_siglist declaration in signal.h or unistd.h" >&5
+echo "configure:3239: checking for sys_siglist declaration in signal.h or unistd.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 3243 "configure"
+#line 3242 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <signal.h>
char *msg = *(sys_siglist + 1);
; return 0; }
EOF
-if { (eval echo configure:3255: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3254: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_decl_sys_siglist=yes
else
echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6
-echo "configure:3280: checking for struct utimbuf" >&5
+echo "configure:3279: checking for struct utimbuf" >&5
cat > conftest.$ac_ext <<EOF
-#line 3282 "configure"
+#line 3281 "configure"
#include "confdefs.h"
#ifdef TIME_WITH_SYS_TIME
#include <sys/time.h>
static struct utimbuf x; x.actime = x.modtime;
; return 0; }
EOF
-if { (eval echo configure:3301: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3300: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
{ test "$extra_verbose" = "yes" && cat << \EOF
rm -f conftest*
echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6
-echo "configure:3321: checking return type of signal handlers" >&5
+echo "configure:3320: checking return type of signal handlers" >&5
cat > conftest.$ac_ext <<EOF
-#line 3324 "configure"
+#line 3323 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <signal.h>
int i;
; return 0; }
EOF
-if { (eval echo configure:3341: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3340: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_type_signal=void
else
echo $ac_n "checking for size_t""... $ac_c" 1>&6
-echo "configure:3363: checking for size_t" >&5
+echo "configure:3362: checking for size_t" >&5
cat > conftest.$ac_ext <<EOF
-#line 3366 "configure"
+#line 3365 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
fi
echo $ac_n "checking for pid_t""... $ac_c" 1>&6
-echo "configure:3397: checking for pid_t" >&5
+echo "configure:3396: checking for pid_t" >&5
cat > conftest.$ac_ext <<EOF
-#line 3400 "configure"
+#line 3399 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
fi
echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
-echo "configure:3431: checking for uid_t in sys/types.h" >&5
+echo "configure:3430: checking for uid_t in sys/types.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 3434 "configure"
+#line 3433 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
fi
echo $ac_n "checking for mode_t""... $ac_c" 1>&6
-echo "configure:3470: checking for mode_t" >&5
+echo "configure:3469: checking for mode_t" >&5
cat > conftest.$ac_ext <<EOF
-#line 3473 "configure"
+#line 3472 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
fi
echo $ac_n "checking for off_t""... $ac_c" 1>&6
-echo "configure:3504: checking for off_t" >&5
+echo "configure:3503: checking for off_t" >&5
cat > conftest.$ac_ext <<EOF
-#line 3507 "configure"
+#line 3506 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
echo $ac_n "checking for struct timeval""... $ac_c" 1>&6
-echo "configure:3539: checking for struct timeval" >&5
+echo "configure:3538: checking for struct timeval" >&5
cat > conftest.$ac_ext <<EOF
-#line 3541 "configure"
+#line 3540 "configure"
#include "confdefs.h"
#ifdef TIME_WITH_SYS_TIME
#include <sys/time.h>
static struct timeval x; x.tv_sec = x.tv_usec;
; return 0; }
EOF
-if { (eval echo configure:3557: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3556: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
HAVE_TIMEVAL=yes
rm -f conftest*
echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
-echo "configure:3579: checking whether struct tm is in sys/time.h or time.h" >&5
+echo "configure:3578: checking whether struct tm is in sys/time.h or time.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 3582 "configure"
+#line 3581 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <time.h>
struct tm *tp; tp->tm_sec;
; return 0; }
EOF
-if { (eval echo configure:3590: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3589: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_tm=time.h
else
fi
echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
-echo "configure:3614: checking for tm_zone in struct tm" >&5
+echo "configure:3613: checking for tm_zone in struct tm" >&5
cat > conftest.$ac_ext <<EOF
-#line 3617 "configure"
+#line 3616 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_cv_struct_tm>
struct tm tm; tm.tm_zone;
; return 0; }
EOF
-if { (eval echo configure:3625: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3624: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_tm_zone=yes
else
else
echo $ac_n "checking for tzname""... $ac_c" 1>&6
-echo "configure:3648: checking for tzname" >&5
+echo "configure:3647: checking for tzname" >&5
cat > conftest.$ac_ext <<EOF
-#line 3651 "configure"
+#line 3650 "configure"
#include "confdefs.h"
#include <time.h>
#ifndef tzname /* For SGI. */
atoi(*tzname);
; return 0; }
EOF
-if { (eval echo configure:3661: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:3660: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_cv_var_tzname=yes
else
echo $ac_n "checking for working const""... $ac_c" 1>&6
-echo "configure:3687: checking for working const" >&5
+echo "configure:3686: checking for working const" >&5
cat > conftest.$ac_ext <<EOF
-#line 3690 "configure"
+#line 3689 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
-if { (eval echo configure:3739: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3738: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_c_const=yes
else
echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
-echo "configure:3764: checking whether ${MAKE-make} sets \${MAKE}" >&5
+echo "configure:3763: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
cat > conftestmake <<\EOF
echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6
-echo "configure:3789: checking whether byte ordering is bigendian" >&5
+echo "configure:3788: checking whether byte ordering is bigendian" >&5
ac_cv_c_bigendian=unknown
# See if sys/param.h defines the BYTE_ORDER macro.
cat > conftest.$ac_ext <<EOF
-#line 3794 "configure"
+#line 3793 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
#endif
; return 0; }
EOF
-if { (eval echo configure:3805: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3804: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
# It does; now see whether it defined to BIG_ENDIAN or not.
cat > conftest.$ac_ext <<EOF
-#line 3809 "configure"
+#line 3808 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
#endif
; return 0; }
EOF
-if { (eval echo configure:3820: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3819: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_c_bigendian=yes
else
rm -f conftest*
if test $ac_cv_c_bigendian = unknown; then
cat > conftest.$ac_ext <<EOF
-#line 3837 "configure"
+#line 3836 "configure"
#include "confdefs.h"
main () {
/* Are we little or big endian? From Harbison&Steele. */
exit (u.c[sizeof (long) - 1] == 1);
}
EOF
-if { (eval echo configure:3850: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:3849: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_c_bigendian=no
else
echo $ac_n "checking size of short""... $ac_c" 1>&6
-echo "configure:3877: checking size of short" >&5
+echo "configure:3876: checking size of short" >&5
cat > conftest.$ac_ext <<EOF
-#line 3880 "configure"
+#line 3879 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
exit(0);
}
EOF
-if { (eval echo configure:3891: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:3890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_sizeof_short=`cat conftestval`
else
exit 1
fi
echo $ac_n "checking size of int""... $ac_c" 1>&6
-echo "configure:3919: checking size of int" >&5
+echo "configure:3918: checking size of int" >&5
cat > conftest.$ac_ext <<EOF
-#line 3922 "configure"
+#line 3921 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
exit(0);
}
EOF
-if { (eval echo configure:3933: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:3932: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_sizeof_int=`cat conftestval`
else
echo $ac_n "checking size of long""... $ac_c" 1>&6
-echo "configure:3955: checking size of long" >&5
+echo "configure:3954: checking size of long" >&5
cat > conftest.$ac_ext <<EOF
-#line 3958 "configure"
+#line 3957 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
exit(0);
}
EOF
-if { (eval echo configure:3969: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:3968: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_sizeof_long=`cat conftestval`
else
echo $ac_n "checking size of long long""... $ac_c" 1>&6
-echo "configure:3991: checking size of long long" >&5
+echo "configure:3990: checking size of long long" >&5
cat > conftest.$ac_ext <<EOF
-#line 3994 "configure"
+#line 3993 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
exit(0);
}
EOF
-if { (eval echo configure:4005: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:4004: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_sizeof_long_long=`cat conftestval`
else
echo $ac_n "checking size of void *""... $ac_c" 1>&6
-echo "configure:4027: checking size of void *" >&5
+echo "configure:4026: checking size of void *" >&5
cat > conftest.$ac_ext <<EOF
-#line 4030 "configure"
+#line 4029 "configure"
#include "confdefs.h"
#include <stdio.h>
main()
exit(0);
}
EOF
-if { (eval echo configure:4041: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:4040: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_sizeof_void_p=`cat conftestval`
else
echo $ac_n "checking for long file names""... $ac_c" 1>&6
-echo "configure:4064: checking for long file names" >&5
+echo "configure:4063: checking for long file names" >&5
ac_cv_sys_long_file_names=yes
# Test for long file names in all the places we know might matter:
echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6
-echo "configure:4111: checking for sin in -lm" >&5
+echo "configure:4110: checking for sin in -lm" >&5
ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'`
xe_check_libs=" -lm "
cat > conftest.$ac_ext <<EOF
-#line 4116 "configure"
+#line 4115 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
sin()
; return 0; }
EOF
-if { (eval echo configure:4127: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4126: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
cat > conftest.$ac_ext <<EOF
-#line 4169 "configure"
+#line 4168 "configure"
#include "confdefs.h"
#include <math.h>
int main() {
return atanh(1.0) + asinh(1.0) + acosh(1.0);
; return 0; }
EOF
-if { (eval echo configure:4176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4175: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
{ test "$extra_verbose" = "yes" && cat << \EOF
Defining HAVE_INVERSE_HYPERBOLIC
rm -f conftest*
echo "checking type of mail spool file locking" 1>&6
-echo "configure:4193: checking type of mail spool file locking" >&5
+echo "configure:4192: checking type of mail spool file locking" >&5
test -z "$mail_locking" -a "$mail_use_flock" = "yes" && mail_locking=flock
test -z "$mail_locking" -a "$mail_use_lockf" = "yes" && mail_locking=lockf
if test "$mail_locking" = "lockf"; then { test "$extra_verbose" = "yes" && cat << \EOF
echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6
-echo "configure:4217: checking for kstat_open in -lkstat" >&5
+echo "configure:4216: checking for kstat_open in -lkstat" >&5
ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'`
xe_check_libs=" -lkstat "
cat > conftest.$ac_ext <<EOF
-#line 4222 "configure"
+#line 4221 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
kstat_open()
; return 0; }
EOF
-if { (eval echo configure:4233: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6
-echo "configure:4267: checking for kvm_read in -lkvm" >&5
+echo "configure:4266: checking for kvm_read in -lkvm" >&5
ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'`
xe_check_libs=" -lkvm "
cat > conftest.$ac_ext <<EOF
-#line 4272 "configure"
+#line 4271 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
kvm_read()
; return 0; }
EOF
-if { (eval echo configure:4283: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4282: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
case "$opsys" in decosf*)
echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6
-echo "configure:4318: checking for cma_open in -lpthreads" >&5
+echo "configure:4317: checking for cma_open in -lpthreads" >&5
ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'`
xe_check_libs=" -lpthreads "
cat > conftest.$ac_ext <<EOF
-#line 4323 "configure"
+#line 4322 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
cma_open()
; return 0; }
EOF
-if { (eval echo configure:4334: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4333: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
esac
echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6
-echo "configure:4370: checking whether the -xildoff compiler flag is required" >&5
+echo "configure:4369: checking whether the -xildoff compiler flag is required" >&5
if ${CC-cc} '-###' -xildon no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then
if ${CC-cc} '-###' -xildoff no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ;
then echo "$ac_t""no" 1>&6;
if test "$opsys" = "sol2" && test "$OS_RELEASE" -ge 56; then
echo $ac_n "checking for \"-z ignore\" linker flag""... $ac_c" 1>&6
-echo "configure:4381: checking for \"-z ignore\" linker flag" >&5
+echo "configure:4380: checking for \"-z ignore\" linker flag" >&5
case "`ld -h 2>&1`" in
*-z\ ignore\|record* ) echo "$ac_t""yes" 1>&6
ld_switch_site="-z ignore $ld_switch_site" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-z ignore\" to \$ld_switch_site"; fi ;;
echo "checking "for specified window system"" 1>&6
-echo "configure:4391: checking "for specified window system"" >&5
+echo "configure:4390: checking "for specified window system"" >&5
if test "$with_x11" != "no"; then
test "$x_includes $x_libraries" != "NONE NONE" && \
# Uses ac_ vars as temps to allow command line to override cache and checks.
# --without-x overrides everything else, but does not touch the cache.
echo $ac_n "checking for X""... $ac_c" 1>&6
-echo "configure:4424: checking for X" >&5
+echo "configure:4423: checking for X" >&5
# Check whether --with-x or --without-x was given.
if test "${with_x+set}" = set; then
# First, try using that file with no special directory specified.
cat > conftest.$ac_ext <<EOF
-#line 4484 "configure"
+#line 4483 "configure"
#include "confdefs.h"
#include <$x_direct_test_include>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:4488: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
ac_save_LIBS="$LIBS"
LIBS="-l$x_direct_test_library $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4558 "configure"
+#line 4557 "configure"
#include "confdefs.h"
int main() {
${x_direct_test_function}()
; return 0; }
EOF
-if { (eval echo configure:4565: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4564: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
LIBS="$ac_save_LIBS"
# We can link X programs with no special library path.
case "`(uname -sr) 2>/dev/null`" in
"SunOS 5"*)
echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6
-echo "configure:4674: checking whether -R must be followed by a space" >&5
+echo "configure:4673: checking whether -R must be followed by a space" >&5
ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries"
cat > conftest.$ac_ext <<EOF
-#line 4677 "configure"
+#line 4676 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
-if { (eval echo configure:4684: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_R_nospace=yes
else
else
LIBS="$ac_xsave_LIBS -R $x_libraries"
cat > conftest.$ac_ext <<EOF
-#line 4700 "configure"
+#line 4699 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
-if { (eval echo configure:4707: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4706: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_R_space=yes
else
else
echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6
-echo "configure:4743: checking for dnet_ntoa in -ldnet" >&5
+echo "configure:4742: checking for dnet_ntoa in -ldnet" >&5
ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldnet "
cat > conftest.$ac_ext <<EOF
-#line 4748 "configure"
+#line 4747 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dnet_ntoa()
; return 0; }
EOF
-if { (eval echo configure:4759: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test $ac_cv_lib_dnet_dnet_ntoa = no; then
echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6
-echo "configure:4783: checking for dnet_ntoa in -ldnet_stub" >&5
+echo "configure:4782: checking for dnet_ntoa in -ldnet_stub" >&5
ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldnet_stub "
cat > conftest.$ac_ext <<EOF
-#line 4788 "configure"
+#line 4787 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dnet_ntoa()
; return 0; }
EOF
-if { (eval echo configure:4799: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
# The nsl library prevents programs from opening the X display
# on Irix 5.2, according to dickey@clark.net.
echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
-echo "configure:4828: checking for gethostbyname" >&5
+echo "configure:4827: checking for gethostbyname" >&5
cat > conftest.$ac_ext <<EOF
-#line 4831 "configure"
+#line 4830 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
; return 0; }
EOF
-if { (eval echo configure:4854: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4853: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_gethostbyname=yes"
else
if test $ac_cv_func_gethostbyname = no; then
echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
-echo "configure:4875: checking for gethostbyname in -lnsl" >&5
+echo "configure:4874: checking for gethostbyname in -lnsl" >&5
ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
xe_check_libs=" -lnsl "
cat > conftest.$ac_ext <<EOF
-#line 4880 "configure"
+#line 4879 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
gethostbyname()
; return 0; }
EOF
-if { (eval echo configure:4891: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
# -lsocket must be given before -lnsl if both are needed.
# We assume that if connect needs -lnsl, so does gethostbyname.
echo $ac_n "checking for connect""... $ac_c" 1>&6
-echo "configure:4921: checking for connect" >&5
+echo "configure:4920: checking for connect" >&5
cat > conftest.$ac_ext <<EOF
-#line 4924 "configure"
+#line 4923 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
; return 0; }
EOF
-if { (eval echo configure:4947: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4946: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_connect=yes"
else
xe_msg_checking="for connect in -lsocket"
test -n "$X_EXTRA_LIBS" && xe_msg_checking="$xe_msg_checking using extra libs $X_EXTRA_LIBS"
echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6
-echo "configure:4970: checking "$xe_msg_checking"" >&5
+echo "configure:4969: checking "$xe_msg_checking"" >&5
ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'`
xe_check_libs=" -lsocket $X_EXTRA_LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4975 "configure"
+#line 4974 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
connect()
; return 0; }
EOF
-if { (eval echo configure:4986: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:4985: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
# gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX.
echo $ac_n "checking for remove""... $ac_c" 1>&6
-echo "configure:5010: checking for remove" >&5
+echo "configure:5009: checking for remove" >&5
cat > conftest.$ac_ext <<EOF
-#line 5013 "configure"
+#line 5012 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char remove(); below. */
; return 0; }
EOF
-if { (eval echo configure:5036: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5035: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_remove=yes"
else
if test $ac_cv_func_remove = no; then
echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6
-echo "configure:5057: checking for remove in -lposix" >&5
+echo "configure:5056: checking for remove in -lposix" >&5
ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'`
xe_check_libs=" -lposix "
cat > conftest.$ac_ext <<EOF
-#line 5062 "configure"
+#line 5061 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
remove()
; return 0; }
EOF
-if { (eval echo configure:5073: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
# BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay.
echo $ac_n "checking for shmat""... $ac_c" 1>&6
-echo "configure:5097: checking for shmat" >&5
+echo "configure:5096: checking for shmat" >&5
cat > conftest.$ac_ext <<EOF
-#line 5100 "configure"
+#line 5099 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char shmat(); below. */
; return 0; }
EOF
-if { (eval echo configure:5123: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5122: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_shmat=yes"
else
if test $ac_cv_func_shmat = no; then
echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6
-echo "configure:5144: checking for shmat in -lipc" >&5
+echo "configure:5143: checking for shmat in -lipc" >&5
ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'`
xe_check_libs=" -lipc "
cat > conftest.$ac_ext <<EOF
-#line 5149 "configure"
+#line 5148 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
shmat()
; return 0; }
EOF
-if { (eval echo configure:5160: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5159: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
# --interran@uluru.Stanford.EDU, kb@cs.umb.edu.
echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6
-echo "configure:5194: checking for IceConnectionNumber in -lICE" >&5
+echo "configure:5193: checking for IceConnectionNumber in -lICE" >&5
ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'`
xe_check_libs=" -lICE "
cat > conftest.$ac_ext <<EOF
-#line 5199 "configure"
+#line 5198 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
IceConnectionNumber()
; return 0; }
EOF
-if { (eval echo configure:5210: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5209: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
set x $ld_switch_run; shift; ld_switch_run=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;;
+ -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;;
-Xlinker* ) ;;
* ) ld_switch_run="$ld_switch_run -Xlinker $1" ;;
esac
echo "checking for X defines extracted by xmkmf" 1>&6
-echo "configure:5379: checking for X defines extracted by xmkmf" >&5
+echo "configure:5378: checking for X defines extracted by xmkmf" >&5
rm -fr conftestdir
if mkdir conftestdir; then
cd conftestdir
ac_safe=`echo "X11/Intrinsic.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for X11/Intrinsic.h""... $ac_c" 1>&6
-echo "configure:5411: checking for X11/Intrinsic.h" >&5
+echo "configure:5410: checking for X11/Intrinsic.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 5414 "configure"
+#line 5413 "configure"
#include "confdefs.h"
#include <X11/Intrinsic.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5419: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:5418: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6
-echo "configure:5443: checking for XOpenDisplay in -lX11" >&5
+echo "configure:5442: checking for XOpenDisplay in -lX11" >&5
ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'`
xe_check_libs=" -lX11 "
cat > conftest.$ac_ext <<EOF
-#line 5448 "configure"
+#line 5447 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XOpenDisplay()
; return 0; }
EOF
-if { (eval echo configure:5459: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5458: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
xe_msg_checking="for XGetFontProperty in -lX11"
test -n "-b i486-linuxaout" && xe_msg_checking="$xe_msg_checking using extra libs -b i486-linuxaout"
echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6
-echo "configure:5484: checking "$xe_msg_checking"" >&5
+echo "configure:5483: checking "$xe_msg_checking"" >&5
ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'`
xe_check_libs=" -lX11 -b i486-linuxaout"
cat > conftest.$ac_ext <<EOF
-#line 5489 "configure"
+#line 5488 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XGetFontProperty()
; return 0; }
EOF
-if { (eval echo configure:5500: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5499: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6
-echo "configure:5527: checking for XShapeSelectInput in -lXext" >&5
+echo "configure:5526: checking for XShapeSelectInput in -lXext" >&5
ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXext "
cat > conftest.$ac_ext <<EOF
-#line 5532 "configure"
+#line 5531 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XShapeSelectInput()
; return 0; }
EOF
-if { (eval echo configure:5543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5542: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6
-echo "configure:5566: checking for XtOpenDisplay in -lXt" >&5
+echo "configure:5565: checking for XtOpenDisplay in -lXt" >&5
ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXt "
cat > conftest.$ac_ext <<EOF
-#line 5571 "configure"
+#line 5570 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XtOpenDisplay()
; return 0; }
EOF
-if { (eval echo configure:5582: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5581: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6
-echo "configure:5605: checking the version of X11 being used" >&5
+echo "configure:5604: checking the version of X11 being used" >&5
cat > conftest.$ac_ext <<EOF
-#line 5607 "configure"
+#line 5606 "configure"
#include "confdefs.h"
#include <X11/Intrinsic.h>
int main(int c, char *v[]) { return c>1 ? XlibSpecificationRelease : 0; }
EOF
-if { (eval echo configure:5612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:5611: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
./conftest foobar; x11_release=$?
else
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:5637: checking for $ac_hdr" >&5
+echo "configure:5636: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 5640 "configure"
+#line 5639 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:5644: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo $ac_n "checking for XFree86""... $ac_c" 1>&6
-echo "configure:5676: checking for XFree86" >&5
+echo "configure:5675: checking for XFree86" >&5
if test -d "/usr/X386/include" -o \
-f "/etc/XF86Config" -o \
-f "/etc/X11/XF86Config" -o \
test -z "$with_xmu" && {
echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6
-echo "configure:5696: checking for XmuReadBitmapDataFromFile in -lXmu" >&5
+echo "configure:5695: checking for XmuReadBitmapDataFromFile in -lXmu" >&5
ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXmu "
cat > conftest.$ac_ext <<EOF
-#line 5701 "configure"
+#line 5700 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XmuReadBitmapDataFromFile()
; return 0; }
EOF
-if { (eval echo configure:5712: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6
-echo "configure:5751: checking for main in -lXbsd" >&5
+echo "configure:5750: checking for main in -lXbsd" >&5
ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXbsd "
cat > conftest.$ac_ext <<EOF
-#line 5756 "configure"
+#line 5755 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:5763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5762: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
if test "$with_msw" != "no"; then
echo "checking for MS-Windows" 1>&6
-echo "configure:5800: checking for MS-Windows" >&5
+echo "configure:5799: checking for MS-Windows" >&5
echo $ac_n "checking for main in -lgdi32""... $ac_c" 1>&6
-echo "configure:5803: checking for main in -lgdi32" >&5
+echo "configure:5802: checking for main in -lgdi32" >&5
ac_lib_var=`echo gdi32'_'main | sed 'y%./+-%__p_%'`
xe_check_libs=" -lgdi32 "
cat > conftest.$ac_ext <<EOF
-#line 5808 "configure"
+#line 5807 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:5815: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:5814: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo " xemacs will be linked with \"dialog-msw.o\""
fi
else
- test "$with_scrollbars" != "no" && extra_objs="$extra_objs scrollbar-msw.o" && if test "$extra_verbose" = "yes"; then
+ test "$with_scrollbars" != "no" && extra_objs="$extra_objs scrollbar-msw.o" && if test "$extra_verbose" = "yes"; then
echo " xemacs will be linked with \"scrollbar-msw.o\""
fi
test "$with_menubars" != "no" && extra_objs="$extra_objs menubar-msw.o" && if test "$extra_verbose" = "yes"; then
test "$with_toolbars" != "no" && extra_objs="$extra_objs toolbar-msw.o" && if test "$extra_verbose" = "yes"; then
echo " xemacs will be linked with \"toolbar-msw.o\""
fi
- test "$with_dialogs" != "no" && extra_objs="$extra_objs dialog-msw.o" && if test "$extra_verbose" = "yes"; then
+ test "$with_dialogs" != "no" && extra_objs="$extra_objs dialog-msw.o" && if test "$extra_verbose" = "yes"; then
echo " xemacs will be linked with \"dialog-msw.o\""
fi
fi
cat > conftest.$ac_ext <<EOF
-#line 5880 "configure"
+#line 5879 "configure"
#include "confdefs.h"
#include <fcntl.h>
int main() { return (open("/dev/windows", O_RDONLY, 0) > 0)? 0 : 1; }
EOF
-if { (eval echo configure:5885: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:5884: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
{ test "$extra_verbose" = "yes" && cat << \EOF
Defining HAVE_MSG_SELECT
esac
echo "checking for session-management option" 1>&6
-echo "configure:5964: checking for session-management option" >&5;
+echo "configure:5963: checking for session-management option" >&5;
if test "$with_session" != "no"; then
{ test "$extra_verbose" = "yes" && cat << \EOF
Defining HAVE_SESSION
test -z "$with_xauth" && test "$window_system" = "none" && with_xauth=no
test -z "$with_xauth" && { ac_safe=`echo "X11/Xauth.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for X11/Xauth.h""... $ac_c" 1>&6
-echo "configure:5979: checking for X11/Xauth.h" >&5
+echo "configure:5978: checking for X11/Xauth.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 5982 "configure"
+#line 5981 "configure"
#include "confdefs.h"
#include <X11/Xauth.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5987: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:5986: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_xauth" && {
echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6
-echo "configure:6010: checking for XauGetAuthByAddr in -lXau" >&5
+echo "configure:6009: checking for XauGetAuthByAddr in -lXau" >&5
ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXau "
cat > conftest.$ac_ext <<EOF
-#line 6015 "configure"
+#line 6014 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XauGetAuthByAddr()
; return 0; }
EOF
-if { (eval echo configure:6026: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6025: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
for dir in "" "Tt/" "desktop/" ; do
ac_safe=`echo "${dir}tt_c.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for ${dir}tt_c.h""... $ac_c" 1>&6
-echo "configure:6071: checking for ${dir}tt_c.h" >&5
+echo "configure:6070: checking for ${dir}tt_c.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6074 "configure"
+#line 6073 "configure"
#include "confdefs.h"
#include <${dir}tt_c.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6079: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6078: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
xe_msg_checking="for tt_message_create in -ltt"
test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs"
echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6
-echo "configure:6115: checking "$xe_msg_checking"" >&5
+echo "configure:6114: checking "$xe_msg_checking"" >&5
ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'`
xe_check_libs=" -ltt $extra_libs"
cat > conftest.$ac_ext <<EOF
-#line 6120 "configure"
+#line 6119 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
tt_message_create()
; return 0; }
EOF
-if { (eval echo configure:6131: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6130: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
test -z "$with_cde" && { ac_safe=`echo "Dt/Dt.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for Dt/Dt.h""... $ac_c" 1>&6
-echo "configure:6188: checking for Dt/Dt.h" >&5
+echo "configure:6187: checking for Dt/Dt.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6191 "configure"
+#line 6190 "configure"
#include "confdefs.h"
#include <Dt/Dt.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6196: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6195: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_cde" && {
echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6
-echo "configure:6219: checking for DtDndDragStart in -lDtSvc" >&5
+echo "configure:6218: checking for DtDndDragStart in -lDtSvc" >&5
ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'`
xe_check_libs=" -lDtSvc "
cat > conftest.$ac_ext <<EOF
-#line 6224 "configure"
+#line 6223 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
DtDndDragStart()
; return 0; }
EOF
-if { (eval echo configure:6235: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6234: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
echo $ac_n "checking if drag and drop API is needed""... $ac_c" 1>&6
-echo "configure:6304: checking if drag and drop API is needed" >&5
+echo "configure:6303: checking if drag and drop API is needed" >&5
if test "$with_dragndrop" != "no" ; then
if test -n "$dragndrop_proto" ; then
with_dragndrop=yes
fi
echo "checking for LDAP" 1>&6
-echo "configure:6325: checking for LDAP" >&5
+echo "configure:6324: checking for LDAP" >&5
test -z "$with_ldap" && { ac_safe=`echo "ldap.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for ldap.h""... $ac_c" 1>&6
-echo "configure:6328: checking for ldap.h" >&5
+echo "configure:6327: checking for ldap.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6331 "configure"
+#line 6330 "configure"
#include "confdefs.h"
#include <ldap.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6336: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6335: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_ldap" && { ac_safe=`echo "lber.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for lber.h""... $ac_c" 1>&6
-echo "configure:6359: checking for lber.h" >&5
+echo "configure:6358: checking for lber.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6362 "configure"
+#line 6361 "configure"
#include "confdefs.h"
#include <lber.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6367: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6366: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
xe_msg_checking="for ldap_open in -lldap"
test -n "-llber" && xe_msg_checking="$xe_msg_checking using extra libs -llber"
echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6
-echo "configure:6393: checking "$xe_msg_checking"" >&5
+echo "configure:6392: checking "$xe_msg_checking"" >&5
ac_lib_var=`echo ldap'_'ldap_open | sed 'y%./+-%__p_%'`
xe_check_libs=" -lldap -llber"
cat > conftest.$ac_ext <<EOF
-#line 6398 "configure"
+#line 6397 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
ldap_open()
; return 0; }
EOF
-if { (eval echo configure:6409: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
test "$with_umich_ldap" = "no" && {
echo $ac_n "checking for ldap_set_option in -lldap10""... $ac_c" 1>&6
-echo "configure:6432: checking for ldap_set_option in -lldap10" >&5
+echo "configure:6431: checking for ldap_set_option in -lldap10" >&5
ac_lib_var=`echo ldap10'_'ldap_set_option | sed 'y%./+-%__p_%'`
xe_check_libs=" -lldap10 "
cat > conftest.$ac_ext <<EOF
-#line 6437 "configure"
+#line 6436 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
ldap_set_option()
; return 0; }
EOF
-if { (eval echo configure:6448: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6447: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$window_system" != "none"; then
echo "checking for graphics libraries" 1>&6
-echo "configure:6512: checking for graphics libraries" >&5
+echo "configure:6511: checking for graphics libraries" >&5
xpm_problem=""
if test -z "$with_xpm"; then
echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6
-echo "configure:6517: checking for Xpm - no older than 3.4f" >&5
+echo "configure:6516: checking for Xpm - no older than 3.4f" >&5
xe_check_libs=-lXpm
cat > conftest.$ac_ext <<EOF
-#line 6520 "configure"
+#line 6519 "configure"
#include "confdefs.h"
#include <X11/xpm.h>
int main(int c, char **v) {
XpmIncludeVersion != XpmLibraryVersion() ? 1 :
XpmIncludeVersion < 30406 ? 2 : 0 ;}
EOF
-if { (eval echo configure:6528: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:6527: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
./conftest dummy_arg; xpm_status=$?;
if test "$xpm_status" = "0"; then
libs_x="-lXpm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXpm\" to \$libs_x"; fi
echo $ac_n "checking for \"FOR_MSW\" xpm""... $ac_c" 1>&6
-echo "configure:6570: checking for \"FOR_MSW\" xpm" >&5
+echo "configure:6569: checking for \"FOR_MSW\" xpm" >&5
xe_check_libs=-lXpm
cat > conftest.$ac_ext <<EOF
-#line 6573 "configure"
+#line 6572 "configure"
#include "confdefs.h"
int main() {
XpmCreatePixmapFromData()
; return 0; }
EOF
-if { (eval echo configure:6580: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6579: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
xpm_for_msw=no
else
if test "$with_png $with_tiff" != "no no"; then
echo $ac_n "checking for inflate in -lc""... $ac_c" 1>&6
-echo "configure:6622: checking for inflate in -lc" >&5
+echo "configure:6621: checking for inflate in -lc" >&5
ac_lib_var=`echo c'_'inflate | sed 'y%./+-%__p_%'`
xe_check_libs=" -lc "
cat > conftest.$ac_ext <<EOF
-#line 6627 "configure"
+#line 6626 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
inflate()
; return 0; }
EOF
-if { (eval echo configure:6638: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6637: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for inflate in -lz""... $ac_c" 1>&6
-echo "configure:6657: checking for inflate in -lz" >&5
+echo "configure:6656: checking for inflate in -lz" >&5
ac_lib_var=`echo z'_'inflate | sed 'y%./+-%__p_%'`
xe_check_libs=" -lz "
cat > conftest.$ac_ext <<EOF
-#line 6662 "configure"
+#line 6661 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
inflate()
; return 0; }
EOF
-if { (eval echo configure:6673: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6672: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for inflate in -lgz""... $ac_c" 1>&6
-echo "configure:6692: checking for inflate in -lgz" >&5
+echo "configure:6691: checking for inflate in -lgz" >&5
ac_lib_var=`echo gz'_'inflate | sed 'y%./+-%__p_%'`
xe_check_libs=" -lgz "
cat > conftest.$ac_ext <<EOF
-#line 6697 "configure"
+#line 6696 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
inflate()
; return 0; }
EOF
-if { (eval echo configure:6708: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6707: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
test -z "$with_jpeg" && { ac_safe=`echo "jpeglib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for jpeglib.h""... $ac_c" 1>&6
-echo "configure:6738: checking for jpeglib.h" >&5
+echo "configure:6737: checking for jpeglib.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6741 "configure"
+#line 6740 "configure"
#include "confdefs.h"
#include <jpeglib.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6746: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6745: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_jpeg" && {
echo $ac_n "checking for jpeg_destroy_decompress in -ljpeg""... $ac_c" 1>&6
-echo "configure:6769: checking for jpeg_destroy_decompress in -ljpeg" >&5
+echo "configure:6768: checking for jpeg_destroy_decompress in -ljpeg" >&5
ac_lib_var=`echo jpeg'_'jpeg_destroy_decompress | sed 'y%./+-%__p_%'`
xe_check_libs=" -ljpeg "
cat > conftest.$ac_ext <<EOF
-#line 6774 "configure"
+#line 6773 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
jpeg_destroy_decompress()
; return 0; }
EOF
-if { (eval echo configure:6785: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6784: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
png_problem=""
test -z "$with_png" && { echo $ac_n "checking for pow""... $ac_c" 1>&6
-echo "configure:6821: checking for pow" >&5
+echo "configure:6820: checking for pow" >&5
cat > conftest.$ac_ext <<EOF
-#line 6824 "configure"
+#line 6823 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char pow(); below. */
; return 0; }
EOF
-if { (eval echo configure:6847: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6846: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_pow=yes"
else
}
test -z "$with_png" && { ac_safe=`echo "png.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for png.h""... $ac_c" 1>&6
-echo "configure:6868: checking for png.h" >&5
+echo "configure:6867: checking for png.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6871 "configure"
+#line 6870 "configure"
#include "confdefs.h"
#include <png.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:6876: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6875: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_png" && {
echo $ac_n "checking for png_read_image in -lpng""... $ac_c" 1>&6
-echo "configure:6899: checking for png_read_image in -lpng" >&5
+echo "configure:6898: checking for png_read_image in -lpng" >&5
ac_lib_var=`echo png'_'png_read_image | sed 'y%./+-%__p_%'`
xe_check_libs=" -lpng "
cat > conftest.$ac_ext <<EOF
-#line 6904 "configure"
+#line 6903 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
png_read_image()
; return 0; }
EOF
-if { (eval echo configure:6915: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:6914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
if test -z "$with_png"; then
echo $ac_n "checking for workable png version information""... $ac_c" 1>&6
-echo "configure:6938: checking for workable png version information" >&5
+echo "configure:6937: checking for workable png version information" >&5
xe_check_libs="-lpng -lz"
cat > conftest.$ac_ext <<EOF
-#line 6941 "configure"
+#line 6940 "configure"
#include "confdefs.h"
#include <png.h>
int main(int c, char **v) {
if (strcmp(png_libpng_ver, PNG_LIBPNG_VER_STRING) != 0) return 1;
return (PNG_LIBPNG_VER < 10002) ? 2 : 0 ;}
EOF
-if { (eval echo configure:6949: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:6948: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
./conftest dummy_arg; png_status=$?;
if test "$png_status" = "0"; then
test -z "$with_tiff" && { ac_safe=`echo "tiffio.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for tiffio.h""... $ac_c" 1>&6
-echo "configure:6992: checking for tiffio.h" >&5
+echo "configure:6991: checking for tiffio.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 6995 "configure"
+#line 6994 "configure"
#include "confdefs.h"
#include <tiffio.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:7000: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6999: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_tiff" && {
echo $ac_n "checking for TIFFClientOpen in -ltiff""... $ac_c" 1>&6
-echo "configure:7023: checking for TIFFClientOpen in -ltiff" >&5
+echo "configure:7022: checking for TIFFClientOpen in -ltiff" >&5
ac_lib_var=`echo tiff'_'TIFFClientOpen | sed 'y%./+-%__p_%'`
xe_check_libs=" -ltiff "
cat > conftest.$ac_ext <<EOF
-#line 7028 "configure"
+#line 7027 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
TIFFClientOpen()
; return 0; }
EOF
-if { (eval echo configure:7039: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7038: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$with_x11" = "yes"; then
echo "checking for X11 graphics libraries" 1>&6
-echo "configure:7078: checking for X11 graphics libraries" >&5
+echo "configure:7077: checking for X11 graphics libraries" >&5
test -z "$with_xface" && { ac_safe=`echo "compface.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for compface.h""... $ac_c" 1>&6
-echo "configure:7082: checking for compface.h" >&5
+echo "configure:7081: checking for compface.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 7085 "configure"
+#line 7084 "configure"
#include "confdefs.h"
#include <compface.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:7090: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:7089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_xface" && {
echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6
-echo "configure:7113: checking for UnGenFace in -lcompface" >&5
+echo "configure:7112: checking for UnGenFace in -lcompface" >&5
ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'`
xe_check_libs=" -lcompface "
cat > conftest.$ac_ext <<EOF
-#line 7118 "configure"
+#line 7117 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
UnGenFace()
; return 0; }
EOF
-if { (eval echo configure:7129: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7128: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6
-echo "configure:7165: checking for XawScrollbarSetThumb in -lXaw" >&5
+echo "configure:7164: checking for XawScrollbarSetThumb in -lXaw" >&5
ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXaw "
cat > conftest.$ac_ext <<EOF
-#line 7170 "configure"
+#line 7169 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XawScrollbarSetThumb()
; return 0; }
EOF
-if { (eval echo configure:7181: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7180: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
ac_safe=`echo "Xm/Xm.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for Xm/Xm.h""... $ac_c" 1>&6
-echo "configure:7205: checking for Xm/Xm.h" >&5
+echo "configure:7204: checking for Xm/Xm.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 7208 "configure"
+#line 7207 "configure"
#include "confdefs.h"
#include <Xm/Xm.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:7213: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:7212: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6
-echo "configure:7230: checking for XmStringFree in -lXm" >&5
+echo "configure:7229: checking for XmStringFree in -lXm" >&5
ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXm "
cat > conftest.$ac_ext <<EOF
-#line 7235 "configure"
+#line 7234 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XmStringFree()
; return 0; }
EOF
-if { (eval echo configure:7246: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7245: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$have_motif" = "yes"; then
echo $ac_n "checking for Lesstif""... $ac_c" 1>&6
-echo "configure:7275: checking for Lesstif" >&5
+echo "configure:7274: checking for Lesstif" >&5
cat > conftest.$ac_ext <<EOF
-#line 7277 "configure"
+#line 7276 "configure"
#include "confdefs.h"
#include <Xm/Xm.h>
#ifdef LESSTIF_VERSION
if test "$with_mule" = "yes" ; then
echo "checking for Mule-related features" 1>&6
-echo "configure:7561: checking for Mule-related features" >&5
+echo "configure:7560: checking for Mule-related features" >&5
{ test "$extra_verbose" = "yes" && cat << \EOF
Defining MULE
EOF
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:7586: checking for $ac_hdr" >&5
+echo "configure:7585: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 7589 "configure"
+#line 7588 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:7594: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:7593: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6
-echo "configure:7625: checking for strerror in -lintl" >&5
+echo "configure:7624: checking for strerror in -lintl" >&5
ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'`
xe_check_libs=" -lintl "
cat > conftest.$ac_ext <<EOF
-#line 7630 "configure"
+#line 7629 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
strerror()
; return 0; }
EOF
-if { (eval echo configure:7641: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7640: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "checking for Mule input methods" 1>&6
-echo "configure:7674: checking for Mule input methods" >&5
+echo "configure:7673: checking for Mule input methods" >&5
case "$with_xim" in "" | "yes" )
echo "checking for XIM" 1>&6
-echo "configure:7677: checking for XIM" >&5
+echo "configure:7676: checking for XIM" >&5
if test "$have_lesstif" = "yes"; then with_xim=xlib
else
echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6
-echo "configure:7681: checking for XmImMbLookupString in -lXm" >&5
+echo "configure:7680: checking for XmImMbLookupString in -lXm" >&5
ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'`
xe_check_libs=" -lXm "
cat > conftest.$ac_ext <<EOF
-#line 7686 "configure"
+#line 7685 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XmImMbLookupString()
; return 0; }
EOF
-if { (eval echo configure:7697: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7696: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$with_xfs" = "yes" ; then
echo "checking for XFontSet" 1>&6
-echo "configure:7763: checking for XFontSet" >&5
+echo "configure:7762: checking for XFontSet" >&5
echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6
-echo "configure:7766: checking for XmbDrawString in -lX11" >&5
+echo "configure:7765: checking for XmbDrawString in -lX11" >&5
ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'`
xe_check_libs=" -lX11 "
cat > conftest.$ac_ext <<EOF
-#line 7771 "configure"
+#line 7770 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
XmbDrawString()
; return 0; }
EOF
-if { (eval echo configure:7782: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7781: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
test "$with_wnn6" = "yes" && with_wnn=yes # wnn6 implies wnn support
test -z "$with_wnn" && { ac_safe=`echo "wnn/jllib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for wnn/jllib.h""... $ac_c" 1>&6
-echo "configure:7822: checking for wnn/jllib.h" >&5
+echo "configure:7821: checking for wnn/jllib.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 7825 "configure"
+#line 7824 "configure"
#include "confdefs.h"
#include <wnn/jllib.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:7830: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:7829: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
for ac_func in crypt
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:7855: checking for $ac_func" >&5
+echo "configure:7854: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 7858 "configure"
+#line 7857 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:7881: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7880: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
test "$ac_cv_func_crypt" != "yes" && {
echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6
-echo "configure:7910: checking for crypt in -lcrypt" >&5
+echo "configure:7909: checking for crypt in -lcrypt" >&5
ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'`
xe_check_libs=" -lcrypt "
cat > conftest.$ac_ext <<EOF
-#line 7915 "configure"
+#line 7914 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
crypt()
; return 0; }
EOF
-if { (eval echo configure:7926: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test -z "$with_wnn" -o "$with_wnn" = "yes"; then
echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6
-echo "configure:7961: checking for jl_dic_list_e in -lwnn" >&5
+echo "configure:7960: checking for jl_dic_list_e in -lwnn" >&5
ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'`
xe_check_libs=" -lwnn "
cat > conftest.$ac_ext <<EOF
-#line 7966 "configure"
+#line 7965 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
jl_dic_list_e()
; return 0; }
EOF
-if { (eval echo configure:7977: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:7976: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for jl_dic_list_e in -lwnn4""... $ac_c" 1>&6
-echo "configure:7995: checking for jl_dic_list_e in -lwnn4" >&5
+echo "configure:7994: checking for jl_dic_list_e in -lwnn4" >&5
ac_lib_var=`echo wnn4'_'jl_dic_list_e | sed 'y%./+-%__p_%'`
xe_check_libs=" -lwnn4 "
cat > conftest.$ac_ext <<EOF
-#line 8000 "configure"
+#line 7999 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
jl_dic_list_e()
; return 0; }
EOF
-if { (eval echo configure:8011: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8010: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for jl_dic_list_e in -lwnn6""... $ac_c" 1>&6
-echo "configure:8029: checking for jl_dic_list_e in -lwnn6" >&5
+echo "configure:8028: checking for jl_dic_list_e in -lwnn6" >&5
ac_lib_var=`echo wnn6'_'jl_dic_list_e | sed 'y%./+-%__p_%'`
xe_check_libs=" -lwnn6 "
cat > conftest.$ac_ext <<EOF
-#line 8034 "configure"
+#line 8033 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
jl_dic_list_e()
; return 0; }
EOF
-if { (eval echo configure:8045: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8044: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for dic_list_e in -lwnn6_fromsrc""... $ac_c" 1>&6
-echo "configure:8063: checking for dic_list_e in -lwnn6_fromsrc" >&5
+echo "configure:8062: checking for dic_list_e in -lwnn6_fromsrc" >&5
ac_lib_var=`echo wnn6_fromsrc'_'dic_list_e | sed 'y%./+-%__p_%'`
xe_check_libs=" -lwnn6_fromsrc "
cat > conftest.$ac_ext <<EOF
-#line 8068 "configure"
+#line 8067 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dic_list_e()
; return 0; }
EOF
-if { (eval echo configure:8079: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8078: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$with_wnn6" != "no"; then
echo $ac_n "checking for jl_fi_dic_list in -l$libwnn""... $ac_c" 1>&6
-echo "configure:8127: checking for jl_fi_dic_list in -l$libwnn" >&5
+echo "configure:8126: checking for jl_fi_dic_list in -l$libwnn" >&5
ac_lib_var=`echo $libwnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'`
xe_check_libs=" -l$libwnn "
cat > conftest.$ac_ext <<EOF
-#line 8132 "configure"
+#line 8131 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
jl_fi_dic_list()
; return 0; }
EOF
-if { (eval echo configure:8143: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8142: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$with_canna" != "no"; then
ac_safe=`echo "canna/jrkanji.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for canna/jrkanji.h""... $ac_c" 1>&6
-echo "configure:8178: checking for canna/jrkanji.h" >&5
+echo "configure:8177: checking for canna/jrkanji.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 8181 "configure"
+#line 8180 "configure"
#include "confdefs.h"
#include <canna/jrkanji.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:8186: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:8185: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
c_switch_site="$c_switch_site -I/usr/local/canna/include"
ac_safe=`echo "canna/jrkanji.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for canna/jrkanji.h""... $ac_c" 1>&6
-echo "configure:8213: checking for canna/jrkanji.h" >&5
+echo "configure:8212: checking for canna/jrkanji.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 8216 "configure"
+#line 8215 "configure"
#include "confdefs.h"
#include <canna/jrkanji.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:8221: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:8220: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
test -z "$with_canna" && { ac_safe=`echo "canna/RK.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for canna/RK.h""... $ac_c" 1>&6
-echo "configure:8249: checking for canna/RK.h" >&5
+echo "configure:8248: checking for canna/RK.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 8252 "configure"
+#line 8251 "configure"
#include "confdefs.h"
#include <canna/RK.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:8257: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:8256: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_canna" && {
echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6
-echo "configure:8280: checking for RkBgnBun in -lRKC" >&5
+echo "configure:8279: checking for RkBgnBun in -lRKC" >&5
ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'`
xe_check_libs=" -lRKC "
cat > conftest.$ac_ext <<EOF
-#line 8285 "configure"
+#line 8284 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
RkBgnBun()
; return 0; }
EOF
-if { (eval echo configure:8296: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8295: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
test -z "$with_canna" && {
echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6
-echo "configure:8319: checking for jrKanjiControl in -lcanna" >&5
+echo "configure:8318: checking for jrKanjiControl in -lcanna" >&5
ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'`
xe_check_libs=" -lcanna "
cat > conftest.$ac_ext <<EOF
-#line 8324 "configure"
+#line 8323 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
jrKanjiControl()
; return 0; }
EOF
-if { (eval echo configure:8335: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8334: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
libs_x="-lXm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXm\" to \$libs_x"; fi
echo $ac_n "checking for layout_object_getvalue in -li18n""... $ac_c" 1>&6
-echo "configure:8384: checking for layout_object_getvalue in -li18n" >&5
+echo "configure:8383: checking for layout_object_getvalue in -li18n" >&5
ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'`
xe_check_libs=" -li18n "
cat > conftest.$ac_ext <<EOF
-#line 8389 "configure"
+#line 8388 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
layout_object_getvalue()
; return 0; }
EOF
-if { (eval echo configure:8400: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8399: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
set x $ld_switch_run; shift; ld_switch_run=""
while test -n "$1"; do
case $1 in
- -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;;
- -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;;
+ -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;;
-Xlinker* ) ;;
* ) ld_switch_run="$ld_switch_run -Xlinker $1" ;;
esac
for ac_func in cbrt closedir dup2 eaccess fmod fpathconf frexp ftime gethostname getpagesize gettimeofday getcwd getwd logb lrand48 matherr mkdir mktime perror poll random rename res_init rint rmdir select setitimer setpgid setlocale setsid sigblock sighold sigprocmask snprintf strcasecmp strerror tzset ulimit usleep utimes waitpid vsnprintf
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:8486: checking for $ac_func" >&5
+echo "configure:8485: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 8489 "configure"
+#line 8488 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:8512: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8511: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
* ) for ac_func in realpath
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:8553: checking for $ac_func" >&5
+echo "configure:8552: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 8556 "configure"
+#line 8555 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:8579: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8578: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
esac
echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6
-echo "configure:8613: checking whether netdb declares h_errno" >&5
+echo "configure:8612: checking whether netdb declares h_errno" >&5
cat > conftest.$ac_ext <<EOF
-#line 8615 "configure"
+#line 8614 "configure"
#include "confdefs.h"
#include <netdb.h>
int main() {
return h_errno;
; return 0; }
EOF
-if { (eval echo configure:8622: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8621: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
{ test "$extra_verbose" = "yes" && cat << \EOF
rm -f conftest*
echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6
-echo "configure:8642: checking for sigsetjmp" >&5
+echo "configure:8641: checking for sigsetjmp" >&5
cat > conftest.$ac_ext <<EOF
-#line 8644 "configure"
+#line 8643 "configure"
#include "confdefs.h"
#include <setjmp.h>
int main() {
sigjmp_buf bar; sigsetjmp (bar, 0);
; return 0; }
EOF
-if { (eval echo configure:8651: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:8650: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
{ test "$extra_verbose" = "yes" && cat << \EOF
rm -f conftest*
echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6
-echo "configure:8671: checking whether localtime caches TZ" >&5
+echo "configure:8670: checking whether localtime caches TZ" >&5
if test "$ac_cv_func_tzset" = "yes"; then
cat > conftest.$ac_ext <<EOF
-#line 8675 "configure"
+#line 8674 "configure"
#include "confdefs.h"
#include <time.h>
#if STDC_HEADERS
exit (0);
}
EOF
-if { (eval echo configure:8710: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:8709: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
emacs_cv_localtime_cache=no
else
if test "$HAVE_TIMEVAL" = "yes"; then
echo $ac_n "checking whether gettimeofday accepts one or two arguments""... $ac_c" 1>&6
-echo "configure:8740: checking whether gettimeofday accepts one or two arguments" >&5
+echo "configure:8739: checking whether gettimeofday accepts one or two arguments" >&5
cat > conftest.$ac_ext <<EOF
-#line 8742 "configure"
+#line 8741 "configure"
#include "confdefs.h"
#ifdef TIME_WITH_SYS_TIME
; return 0; }
EOF
-if { (eval echo configure:8764: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
echo "$ac_t""two" 1>&6
else
echo $ac_n "checking for inline""... $ac_c" 1>&6
-echo "configure:8786: checking for inline" >&5
+echo "configure:8785: checking for inline" >&5
ac_cv_c_inline=no
for ac_kw in inline __inline__ __inline; do
cat > conftest.$ac_ext <<EOF
-#line 8791 "configure"
+#line 8790 "configure"
#include "confdefs.h"
int main() {
} $ac_kw foo() {
; return 0; }
EOF
-if { (eval echo configure:8798: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:8797: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_c_inline=$ac_kw; break
else
# The Ultrix 4.2 mips builtin alloca declared by alloca.h only works
# for constant arguments. Useless!
echo $ac_n "checking for working alloca.h""... $ac_c" 1>&6
-echo "configure:8848: checking for working alloca.h" >&5
+echo "configure:8847: checking for working alloca.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 8851 "configure"
+#line 8850 "configure"
#include "confdefs.h"
#include <alloca.h>
int main() {
char *p = alloca(2 * sizeof(int));
; return 0; }
EOF
-if { (eval echo configure:8858: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8857: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_cv_header_alloca_h=yes
else
fi
echo $ac_n "checking for alloca""... $ac_c" 1>&6
-echo "configure:8882: checking for alloca" >&5
+echo "configure:8881: checking for alloca" >&5
cat > conftest.$ac_ext <<EOF
-#line 8885 "configure"
+#line 8884 "configure"
#include "confdefs.h"
#ifdef __GNUC__
char *p = (char *) alloca(1);
; return 0; }
EOF
-if { (eval echo configure:8908: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8907: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_cv_func_alloca_works=yes
else
echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6
-echo "configure:8947: checking whether alloca needs Cray hooks" >&5
+echo "configure:8946: checking whether alloca needs Cray hooks" >&5
cat > conftest.$ac_ext <<EOF
-#line 8950 "configure"
+#line 8949 "configure"
#include "confdefs.h"
#if defined(CRAY) && ! defined(CRAY2)
webecray
if test $ac_cv_os_cray = yes; then
for ac_func in _getb67 GETB67 getb67; do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:8974: checking for $ac_func" >&5
+echo "configure:8973: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 8977 "configure"
+#line 8976 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:9000: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:8999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
fi
echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6
-echo "configure:9030: checking stack direction for C alloca" >&5
+echo "configure:9029: checking stack direction for C alloca" >&5
cat > conftest.$ac_ext <<EOF
-#line 9033 "configure"
+#line 9032 "configure"
#include "confdefs.h"
find_stack_direction ()
{
exit (find_stack_direction() < 0);
}
EOF
-if { (eval echo configure:9052: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:9051: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_c_stack_direction=1
else
ac_safe=`echo "vfork.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for vfork.h""... $ac_c" 1>&6
-echo "configure:9081: checking for vfork.h" >&5
+echo "configure:9080: checking for vfork.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 9084 "configure"
+#line 9083 "configure"
#include "confdefs.h"
#include <vfork.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:9089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:9088: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
fi
echo $ac_n "checking for working vfork""... $ac_c" 1>&6
-echo "configure:9117: checking for working vfork" >&5
+echo "configure:9116: checking for working vfork" >&5
cat > conftest.$ac_ext <<EOF
-#line 9120 "configure"
+#line 9119 "configure"
#include "confdefs.h"
/* Thanks to Paul Eggert for this test. */
#include <stdio.h>
}
}
EOF
-if { (eval echo configure:9215: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:9214: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_func_vfork_works=yes
else
echo $ac_n "checking for working strcoll""... $ac_c" 1>&6
-echo "configure:9241: checking for working strcoll" >&5
+echo "configure:9240: checking for working strcoll" >&5
cat > conftest.$ac_ext <<EOF
-#line 9244 "configure"
+#line 9243 "configure"
#include "confdefs.h"
#include <string.h>
main ()
strcoll ("123", "456") >= 0);
}
EOF
-if { (eval echo configure:9254: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:9253: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_func_strcoll_works=yes
else
for ac_func in getpgrp
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:9282: checking for $ac_func" >&5
+echo "configure:9281: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 9285 "configure"
+#line 9284 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:9308: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:9307: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
done
echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6
-echo "configure:9336: checking whether getpgrp takes no argument" >&5
+echo "configure:9335: checking whether getpgrp takes no argument" >&5
cat > conftest.$ac_ext <<EOF
-#line 9339 "configure"
+#line 9338 "configure"
#include "confdefs.h"
/*
}
EOF
-if { (eval echo configure:9394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:9393: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_func_getpgrp_void=yes
else
echo $ac_n "checking for working mmap""... $ac_c" 1>&6
-echo "configure:9421: checking for working mmap" >&5
+echo "configure:9420: checking for working mmap" >&5
case "$opsys" in ultrix* ) have_mmap=no ;; *)
cat > conftest.$ac_ext <<EOF
-#line 9424 "configure"
+#line 9423 "configure"
#include "confdefs.h"
#include <stdio.h>
#include <unistd.h>
return 1;
}
EOF
-if { (eval echo configure:9457: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:9456: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
have_mmap=yes
else
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:9482: checking for $ac_hdr" >&5
+echo "configure:9481: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 9485 "configure"
+#line 9484 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:9490: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:9489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
for ac_func in getpagesize
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:9522: checking for $ac_func" >&5
+echo "configure:9521: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 9525 "configure"
+#line 9524 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:9548: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:9547: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
done
echo $ac_n "checking for working mmap""... $ac_c" 1>&6
-echo "configure:9576: checking for working mmap" >&5
+echo "configure:9575: checking for working mmap" >&5
cat > conftest.$ac_ext <<EOF
-#line 9579 "configure"
+#line 9578 "configure"
#include "confdefs.h"
/* Thanks to Mike Haertel and Jim Avera for this test.
}
EOF
-if { (eval echo configure:9719: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:9718: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
ac_cv_func_mmap_fixed_mapped=yes
else
ac_safe=`echo "termios.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for termios.h""... $ac_c" 1>&6
-echo "configure:9757: checking for termios.h" >&5
+echo "configure:9756: checking for termios.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 9760 "configure"
+#line 9759 "configure"
#include "confdefs.h"
#include <termios.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:9765: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:9764: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo "$ac_t""no" 1>&6
ac_safe=`echo "termio.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for termio.h""... $ac_c" 1>&6
-echo "configure:9808: checking for termio.h" >&5
+echo "configure:9807: checking for termio.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 9811 "configure"
+#line 9810 "configure"
#include "confdefs.h"
#include <termio.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:9816: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:9815: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo $ac_n "checking for socket""... $ac_c" 1>&6
-echo "configure:9848: checking for socket" >&5
+echo "configure:9847: checking for socket" >&5
cat > conftest.$ac_ext <<EOF
-#line 9851 "configure"
+#line 9850 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char socket(); below. */
; return 0; }
EOF
-if { (eval echo configure:9874: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:9873: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_socket=yes"
else
echo "$ac_t""yes" 1>&6
ac_safe=`echo "netinet/in.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for netinet/in.h""... $ac_c" 1>&6
-echo "configure:9889: checking for netinet/in.h" >&5
+echo "configure:9888: checking for netinet/in.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 9892 "configure"
+#line 9891 "configure"
#include "confdefs.h"
#include <netinet/in.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:9897: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:9896: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
ac_safe=`echo "arpa/inet.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for arpa/inet.h""... $ac_c" 1>&6
-echo "configure:9914: checking for arpa/inet.h" >&5
+echo "configure:9913: checking for arpa/inet.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 9917 "configure"
+#line 9916 "configure"
#include "confdefs.h"
#include <arpa/inet.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:9922: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:9921: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6
-echo "configure:9947: checking "for sun_len member in struct sockaddr_un"" >&5
+echo "configure:9946: checking "for sun_len member in struct sockaddr_un"" >&5
cat > conftest.$ac_ext <<EOF
-#line 9949 "configure"
+#line 9948 "configure"
#include "confdefs.h"
#include <sys/types.h>
static struct sockaddr_un x; x.sun_len = 1;
; return 0; }
EOF
-if { (eval echo configure:9960: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:9959: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF
Defining HAVE_SOCKADDR_SUN_LEN
fi
rm -f conftest*
echo $ac_n "checking "for ip_mreq struct in netinet/in.h"""... $ac_c" 1>&6
-echo "configure:9978: checking "for ip_mreq struct in netinet/in.h"" >&5
+echo "configure:9977: checking "for ip_mreq struct in netinet/in.h"" >&5
cat > conftest.$ac_ext <<EOF
-#line 9980 "configure"
+#line 9979 "configure"
#include "confdefs.h"
#include <sys/types.h>
static struct ip_mreq x;
; return 0; }
EOF
-if { (eval echo configure:9990: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:9989: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF
Defining HAVE_MULTICAST
echo $ac_n "checking for msgget""... $ac_c" 1>&6
-echo "configure:10021: checking for msgget" >&5
+echo "configure:10020: checking for msgget" >&5
cat > conftest.$ac_ext <<EOF
-#line 10024 "configure"
+#line 10023 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char msgget(); below. */
; return 0; }
EOF
-if { (eval echo configure:10047: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10046: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_msgget=yes"
else
echo "$ac_t""yes" 1>&6
ac_safe=`echo "sys/ipc.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/ipc.h""... $ac_c" 1>&6
-echo "configure:10062: checking for sys/ipc.h" >&5
+echo "configure:10061: checking for sys/ipc.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10065 "configure"
+#line 10064 "configure"
#include "confdefs.h"
#include <sys/ipc.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10070: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10069: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
ac_safe=`echo "sys/msg.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/msg.h""... $ac_c" 1>&6
-echo "configure:10087: checking for sys/msg.h" >&5
+echo "configure:10086: checking for sys/msg.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10090 "configure"
+#line 10089 "configure"
#include "confdefs.h"
#include <sys/msg.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10095: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10094: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "dirent.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dirent.h""... $ac_c" 1>&6
-echo "configure:10133: checking for dirent.h" >&5
+echo "configure:10132: checking for dirent.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10136 "configure"
+#line 10135 "configure"
#include "confdefs.h"
#include <dirent.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10141: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10140: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo "$ac_t""no" 1>&6
ac_safe=`echo "sys/dir.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/dir.h""... $ac_c" 1>&6
-echo "configure:10168: checking for sys/dir.h" >&5
+echo "configure:10167: checking for sys/dir.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10171 "configure"
+#line 10170 "configure"
#include "confdefs.h"
#include <sys/dir.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10176: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10175: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "nlist.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for nlist.h""... $ac_c" 1>&6
-echo "configure:10209: checking for nlist.h" >&5
+echo "configure:10208: checking for nlist.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10212 "configure"
+#line 10211 "configure"
#include "confdefs.h"
#include <nlist.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10217: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10216: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
echo "checking "for sound support"" 1>&6
-echo "configure:10247: checking "for sound support"" >&5
+echo "configure:10246: checking "for sound support"" >&5
case "$with_sound" in
native | both ) with_native_sound=yes;;
nas | no ) with_native_sound=no;;
if test -n "$native_sound_lib"; then
ac_safe=`echo "multimedia/audio_device.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for multimedia/audio_device.h""... $ac_c" 1>&6
-echo "configure:10258: checking for multimedia/audio_device.h" >&5
+echo "configure:10257: checking for multimedia/audio_device.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10261 "configure"
+#line 10260 "configure"
#include "confdefs.h"
#include <multimedia/audio_device.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10266: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10265: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
if test -z "$native_sound_lib"; then
echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6
-echo "configure:10314: checking for ALopenport in -laudio" >&5
+echo "configure:10313: checking for ALopenport in -laudio" >&5
ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'`
xe_check_libs=" -laudio "
cat > conftest.$ac_ext <<EOF
-#line 10319 "configure"
+#line 10318 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
ALopenport()
; return 0; }
EOF
-if { (eval echo configure:10330: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10329: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test -z "$native_sound_lib"; then
echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6
-echo "configure:10361: checking for AOpenAudio in -lAlib" >&5
+echo "configure:10360: checking for AOpenAudio in -lAlib" >&5
ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'`
xe_check_libs=" -lAlib "
cat > conftest.$ac_ext <<EOF
-#line 10366 "configure"
+#line 10365 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
AOpenAudio()
; return 0; }
EOF
-if { (eval echo configure:10377: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10376: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
for dir in "machine" "sys" "linux"; do
ac_safe=`echo "${dir}/soundcard.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for ${dir}/soundcard.h""... $ac_c" 1>&6
-echo "configure:10415: checking for ${dir}/soundcard.h" >&5
+echo "configure:10414: checking for ${dir}/soundcard.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10418 "configure"
+#line 10417 "configure"
#include "confdefs.h"
#include <${dir}/soundcard.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10423: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10422: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
fi
libs_x="-laudio $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-laudio\" to \$libs_x"; fi
cat > conftest.$ac_ext <<EOF
-#line 10493 "configure"
+#line 10492 "configure"
#include "confdefs.h"
#include <audio/Xtutil.h>
EOF
if test "$with_tty" = "yes" ; then
echo "checking for TTY-related features" 1>&6
-echo "configure:10520: checking for TTY-related features" >&5
+echo "configure:10519: checking for TTY-related features" >&5
{ test "$extra_verbose" = "yes" && cat << \EOF
Defining HAVE_TTY
EOF
if test -z "$with_ncurses"; then
echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6
-echo "configure:10536: checking for tgetent in -lncurses" >&5
+echo "configure:10535: checking for tgetent in -lncurses" >&5
ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'`
xe_check_libs=" -lncurses "
cat > conftest.$ac_ext <<EOF
-#line 10541 "configure"
+#line 10540 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
tgetent()
; return 0; }
EOF
-if { (eval echo configure:10552: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10551: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6
-echo "configure:10585: checking for ncurses/curses.h" >&5
+echo "configure:10584: checking for ncurses/curses.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10588 "configure"
+#line 10587 "configure"
#include "confdefs.h"
#include <ncurses/curses.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10593: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10592: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "ncurses/term.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for ncurses/term.h""... $ac_c" 1>&6
-echo "configure:10615: checking for ncurses/term.h" >&5
+echo "configure:10614: checking for ncurses/term.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10618 "configure"
+#line 10617 "configure"
#include "confdefs.h"
#include <ncurses/term.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10623: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10622: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
c_switch_site="$c_switch_site -I/usr/include/ncurses"
ac_safe=`echo "ncurses/curses.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for ncurses/curses.h""... $ac_c" 1>&6
-echo "configure:10653: checking for ncurses/curses.h" >&5
+echo "configure:10652: checking for ncurses/curses.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10656 "configure"
+#line 10655 "configure"
#include "confdefs.h"
#include <ncurses/curses.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10661: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10660: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
for lib in curses termlib termcap; do
echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6
-echo "configure:10696: checking for tgetent in -l$lib" >&5
+echo "configure:10695: checking for tgetent in -l$lib" >&5
ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'`
xe_check_libs=" -l$lib "
cat > conftest.$ac_ext <<EOF
-#line 10701 "configure"
+#line 10700 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
tgetent()
; return 0; }
EOF
-if { (eval echo configure:10712: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
else
echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6
-echo "configure:10743: checking for tgetent in -lcurses" >&5
+echo "configure:10742: checking for tgetent in -lcurses" >&5
ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'`
xe_check_libs=" -lcurses "
cat > conftest.$ac_ext <<EOF
-#line 10748 "configure"
+#line 10747 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
tgetent()
; return 0; }
EOF
-if { (eval echo configure:10759: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6
-echo "configure:10777: checking for tgetent in -ltermcap" >&5
+echo "configure:10776: checking for tgetent in -ltermcap" >&5
ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'`
xe_check_libs=" -ltermcap "
cat > conftest.$ac_ext <<EOF
-#line 10782 "configure"
+#line 10781 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
tgetent()
; return 0; }
EOF
-if { (eval echo configure:10793: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10792: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
test -z "$with_gpm" && { ac_safe=`echo "gpm.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for gpm.h""... $ac_c" 1>&6
-echo "configure:10841: checking for gpm.h" >&5
+echo "configure:10840: checking for gpm.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 10844 "configure"
+#line 10843 "configure"
#include "confdefs.h"
#include <gpm.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10849: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10848: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
}
test -z "$with_gpm" && {
echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6
-echo "configure:10872: checking for Gpm_Open in -lgpm" >&5
+echo "configure:10871: checking for Gpm_Open in -lgpm" >&5
ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'`
xe_check_libs=" -lgpm "
cat > conftest.$ac_ext <<EOF
-#line 10877 "configure"
+#line 10876 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
Gpm_Open()
; return 0; }
EOF
-if { (eval echo configure:10888: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10887: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "checking for database support" 1>&6
-echo "configure:10937: checking for database support" >&5
+echo "configure:10936: checking for database support" >&5
if test "$with_database_gnudbm" != "no"; then
for ac_hdr in ndbm.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:10944: checking for $ac_hdr" >&5
+echo "configure:10943: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 10947 "configure"
+#line 10946 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:10952: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:10951: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
if test "$have_ndbm_h" = "yes"; then
echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6
-echo "configure:10984: checking for dbm_open in -lgdbm" >&5
+echo "configure:10983: checking for dbm_open in -lgdbm" >&5
ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'`
xe_check_libs=" -lgdbm "
cat > conftest.$ac_ext <<EOF
-#line 10989 "configure"
+#line 10988 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dbm_open()
; return 0; }
EOF
-if { (eval echo configure:11000: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:10999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
if test "$with_database_gnudbm" != "yes"; then
echo $ac_n "checking for dbm_open""... $ac_c" 1>&6
-echo "configure:11023: checking for dbm_open" >&5
+echo "configure:11022: checking for dbm_open" >&5
cat > conftest.$ac_ext <<EOF
-#line 11026 "configure"
+#line 11025 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char dbm_open(); below. */
; return 0; }
EOF
-if { (eval echo configure:11049: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11048: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_dbm_open=yes"
else
if test "$with_database_dbm" != "no"; then
echo $ac_n "checking for dbm_open""... $ac_c" 1>&6
-echo "configure:11085: checking for dbm_open" >&5
+echo "configure:11084: checking for dbm_open" >&5
cat > conftest.$ac_ext <<EOF
-#line 11088 "configure"
+#line 11087 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char dbm_open(); below. */
; return 0; }
EOF
-if { (eval echo configure:11111: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11110: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_dbm_open=yes"
else
if test "$need_libdbm" != "no"; then
echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6
-echo "configure:11132: checking for dbm_open in -ldbm" >&5
+echo "configure:11131: checking for dbm_open in -ldbm" >&5
ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldbm "
cat > conftest.$ac_ext <<EOF
-#line 11137 "configure"
+#line 11136 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dbm_open()
; return 0; }
EOF
-if { (eval echo configure:11148: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11147: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$with_database_berkdb" != "no"; then
echo $ac_n "checking for Berkeley db.h""... $ac_c" 1>&6
-echo "configure:11185: checking for Berkeley db.h" >&5
+echo "configure:11184: checking for Berkeley db.h" >&5
for path in "db/db.h" "db.h"; do
cat > conftest.$ac_ext <<EOF
-#line 11188 "configure"
+#line 11187 "configure"
#include "confdefs.h"
#ifdef HAVE_INTTYPES_H
#define __BIT_TYPES_DEFINED__
; return 0; }
EOF
-if { (eval echo configure:11206: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:11205: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
db_h_path="$path"; break
else
if test "$with_database_berkdb" != "no"; then
echo $ac_n "checking for Berkeley DB version""... $ac_c" 1>&6
-echo "configure:11222: checking for Berkeley DB version" >&5
+echo "configure:11221: checking for Berkeley DB version" >&5
cat > conftest.$ac_ext <<EOF
-#line 11224 "configure"
+#line 11223 "configure"
#include "confdefs.h"
#include <$db_h_path>
#if DB_VERSION_MAJOR > 1
rm -f conftest*
echo $ac_n "checking for $dbfunc""... $ac_c" 1>&6
-echo "configure:11243: checking for $dbfunc" >&5
+echo "configure:11242: checking for $dbfunc" >&5
cat > conftest.$ac_ext <<EOF
-#line 11246 "configure"
+#line 11245 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $dbfunc(); below. */
; return 0; }
EOF
-if { (eval echo configure:11269: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$dbfunc=yes"
else
echo $ac_n "checking for $dbfunc in -ldb""... $ac_c" 1>&6
-echo "configure:11288: checking for $dbfunc in -ldb" >&5
+echo "configure:11287: checking for $dbfunc in -ldb" >&5
ac_lib_var=`echo db'_'$dbfunc | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldb "
cat > conftest.$ac_ext <<EOF
-#line 11293 "configure"
+#line 11292 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
$dbfunc()
; return 0; }
EOF
-if { (eval echo configure:11304: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11303: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
if test "$with_socks" = "yes"; then
echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6
-echo "configure:11368: checking for SOCKSinit in -lsocks" >&5
+echo "configure:11367: checking for SOCKSinit in -lsocks" >&5
ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'`
xe_check_libs=" -lsocks "
cat > conftest.$ac_ext <<EOF
-#line 11373 "configure"
+#line 11372 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
SOCKSinit()
; return 0; }
EOF
-if { (eval echo configure:11384: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11383: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:11443: checking for $ac_hdr" >&5
+echo "configure:11442: checking for $ac_hdr" >&5
cat > conftest.$ac_ext <<EOF
-#line 11446 "configure"
+#line 11445 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:11451: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:11450: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
test -z "$with_shlib" && test ! -z "$have_dlfcn" && {
echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
-echo "configure:11482: checking for dlopen in -ldl" >&5
+echo "configure:11481: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldl "
cat > conftest.$ac_ext <<EOF
-#line 11487 "configure"
+#line 11486 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dlopen()
; return 0; }
EOF
-if { (eval echo configure:11498: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11497: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
test -z "$with_shlib" && test ! -z "$have_dlfcn" && {
echo $ac_n "checking for _dlopen in -lc""... $ac_c" 1>&6
-echo "configure:11527: checking for _dlopen in -lc" >&5
+echo "configure:11526: checking for _dlopen in -lc" >&5
ac_lib_var=`echo c'_'_dlopen | sed 'y%./+-%__p_%'`
xe_check_libs=" -lc "
cat > conftest.$ac_ext <<EOF
-#line 11532 "configure"
+#line 11531 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
_dlopen()
; return 0; }
EOF
-if { (eval echo configure:11543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11542: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
test -z "$with_shlib" && test ! -z "$have_dlfcn" && {
echo $ac_n "checking for dlopen in -lc""... $ac_c" 1>&6
-echo "configure:11572: checking for dlopen in -lc" >&5
+echo "configure:11571: checking for dlopen in -lc" >&5
ac_lib_var=`echo c'_'dlopen | sed 'y%./+-%__p_%'`
xe_check_libs=" -lc "
cat > conftest.$ac_ext <<EOF
-#line 11577 "configure"
+#line 11576 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dlopen()
; return 0; }
EOF
-if { (eval echo configure:11588: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11587: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
test -z "$with_shlib" && {
echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
-echo "configure:11617: checking for shl_load in -ldld" >&5
+echo "configure:11616: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldld "
cat > conftest.$ac_ext <<EOF
-#line 11622 "configure"
+#line 11621 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
shl_load()
; return 0; }
EOF
-if { (eval echo configure:11633: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11632: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
}
test -z "$with_shlib" && {
echo $ac_n "checking for dld_init in -ldld""... $ac_c" 1>&6
-echo "configure:11662: checking for dld_init in -ldld" >&5
+echo "configure:11661: checking for dld_init in -ldld" >&5
ac_lib_var=`echo dld'_'dld_init | sed 'y%./+-%__p_%'`
xe_check_libs=" -ldld "
cat > conftest.$ac_ext <<EOF
-#line 11667 "configure"
+#line 11666 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dld_init()
; return 0; }
EOF
-if { (eval echo configure:11678: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11677: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
dll_oflags="-o "
echo $ac_n "checking how to build a shared library""... $ac_c" 1>&6
-echo "configure:11728: checking how to build a shared library" >&5
+echo "configure:11727: checking how to build a shared library" >&5
case `uname -rs` in
UNIX_SV*|UNIX_System_V*)
dll_lflags="-G"
for ac_func in dlerror
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:11819: checking for $ac_func" >&5
+echo "configure:11818: checking for $ac_func" >&5
cat > conftest.$ac_ext <<EOF
-#line 11822 "configure"
+#line 11821 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:11845: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
+if { (eval echo configure:11844: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
fi
cat > conftest.$ac_ext <<EOF
-#line 11881 "configure"
+#line 11880 "configure"
#include "confdefs.h"
int main(int c,char *v[]){return 0;}
EOF
-if { (eval echo configure:11885: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
+if { (eval echo configure:11884: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5
then
:
else
MAKE_SUBDIR="$MAKE_SUBDIR src" && if test "$extra_verbose" = "yes"; then echo " Appending \"src\" to \$MAKE_SUBDIR"; fi
-internal_makefile_list="Makefile"
+internal_makefile_list="Makefile.in"
SUBDIR_MAKEFILES=''
test -d lock || mkdir lock
for dir in $MAKE_SUBDIR; do
-# The default is yes
+: ${XEMACS_CC:=$CC}
+
+
+
if test "$with_site_lisp" = "no"; then
{ test "$extra_verbose" = "yes" && cat << \EOF
Defining INHIBIT_SITE_LISP
EOF
}
-test "$with_gnu_make" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF
- Defining USE_GNU_MAKE
+test "$no_doc_file" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF
+ Defining NO_DOC_FILE
EOF
cat >> confdefs.h <<\EOF
-#define USE_GNU_MAKE 1
+#define NO_DOC_FILE 1
EOF
}
-test "$no_doc_file" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF
- Defining NO_DOC_FILE
+test "$with_purify" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF
+ Defining PURIFY
EOF
cat >> confdefs.h <<\EOF
-#define NO_DOC_FILE 1
+#define PURIFY 1
EOF
}
native ) echo " Compiling in native sound support." ;;
both ) echo " Compiling in both network and native sound support." ;;
esac
-test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously"
+test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously."
test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB."
test "$with_database_dbm" = yes && echo " Compiling in support for DBM."
test "$with_clash_detection" = yes && \
echo " Clash detection will use \"$lockdir\" for locking files."
echo " movemail will use \"$mail_locking\" for locking mail spool files."
-test "$with_pop" = yes && echo " Using POP for mail access"
-test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication"
-test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host"
+test "$with_pop" = yes && echo " Using POP for mail access."
+test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication."
+test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host."
test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects."
test "$use_minimal_tagbits" = yes && echo " Using Lisp_Objects with minimal tagbits."
test "$use_indexed_lrecord_implementation" = yes && echo " Using indexed lrecord implementation."
echo '")' >> Installation.el
-
# Remove any trailing slashes in these variables.
test -n "$prefix" &&
prefix=`echo '' "$prefix" | sed -e 's:^ ::' -e 's,\([^/]\)/*$,\1,'`
s%@native_sound_lib@%$native_sound_lib%g
s%@sound_cflags@%$sound_cflags%g
s%@dynodump_arch@%$dynodump_arch%g
+s%@XEMACS_CC@%$XEMACS_CC%g
s%@internal_makefile_list@%$internal_makefile_list%g
CEOF
EOF
cat >> $CONFIG_STATUS <<EOF
CPP="$CPP"
- CPPFLAGS="$CPPFLAGS"
top_srcdir="$srcdir"
MAKE_SUBDIR="$MAKE_SUBDIR"
EOF
cat >> $CONFIG_STATUS <<\EOF
-for dir in $MAKE_SUBDIR; do
- echo creating $dir/Makefile
+for dir in . $MAKE_SUBDIR; do
(
cd $dir
rm -f junk.c
-e '/^#/ {
p
d
-}' -e '/./ {
+}' \
+ -e '/./ {
s/\([\"]\)/\\\1/g
s/^/"/
s/$/"/
}' > junk.c;
- $CPP -I. -I${top_srcdir}/src $CPPFLAGS junk.c > junk.cpp;
- < junk.cpp \
- sed -e 's/^#.*//' \
- -e 's/^[ ][ ]*$//' \
- -e 's/^ / /' \
- | sed -n -e '/^..*$/p' \
- | sed '/^"/ {
-s/\\\([\"]\)/\1/g
-s/^[ ]*"//
-s/"[ ]*$//
-}' > Makefile.new
+
+
+
+ echo creating $dir/Makefile
+$CPP -I. -I${top_srcdir}/src junk.c \
+ | sed -e 's/^\#.*//' \
+ -e 's/^[ ][ ]*$//'\
+ -e 's/^ / /' \
+ | sed -n -e '/^..*$/p' \
+ | sed '/^\"/ {
+ s/\\\([\"]\)/\1/g
+ s/^[ ]*\"//
+ s/\"[ ]*$//
+}' > Makefile.new
chmod 444 Makefile.new
mv -f Makefile.new Makefile
- rm -f junk.c junk.cpp
-)
+
+ echo creating $dir/GNUmakefile
+$CPP -I. -I${top_srcdir}/src -DUSE_GNU_MAKE junk.c \
+ | sed -e 's/^\#.*//' \
+ -e 's/^[ ][ ]*$//'\
+ -e 's/^ / /' \
+ | sed -n -e '/^..*$/p' \
+ | sed '/^\"/ {
+ s/\\\([\"]\)/\1/g
+ s/^[ ]*\"//
+ s/\"[ ]*$//
+}' > Makefile.new
+ chmod 444 Makefile.new
+ mv -f Makefile.new GNUmakefile
+
+ rm -f junk.c
+ )
done
sed < config.status >> lib-src/config.values \
chmod +x $CONFIG_STATUS
rm -fr confdefs* $ac_clean_files
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
[[$2]="[$1] $[$2]" && dnl
if test "$extra_verbose" = "yes"; then echo " Prepending \"[$1]\" to \$[$2]"; fi])
+dnl XE_DIE(message)
+define([XE_DIE], [{ echo $1 >&2; exit 1; }])
+
+dnl XE_STRIP_4TH_COMPONENT(var)
+dnl Changes i986-pc-linux-gnu to i986-pc-linux, as God (not RMS) intended.
+define([XE_STRIP_4TH_COMPONENT],
+[$1=`echo "$$1" | sed '[s/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/]'`])
dnl Initialize some variables set by options.
dnl The variables have the same names as the options, with
XE_APPEND(lib-src, MAKE_SUBDIR)
XE_APPEND(lib-src, INSTALL_ARCH_DEP_SUBDIR)
-dnl run_in_place='no'
prefix='/usr/local'
exec_prefix='${prefix}'
bindir='${exec_prefix}/bin'
case "$opt" in
dnl Process (many) boolean options
- run_in_place | \
- with_site_lisp | \
+ with_site_lisp | \
with_x | \
with_x11 | \
with_msw | \
with_gcc | \
- with_gnu_make | \
dynamic | \
with_ncurses | \
with_dnet | \
with_tiff | \
with_session | \
with_xmu | \
+ with_purify | \
with_quantify | \
with_toolbars | \
with_tty | \
with_xfs | \
with_i18n3 | \
with_mule | \
- with_file_coding | \
+ with_file_coding| \
with_canna | \
with_wnn | \
with_wnn6 | \
with_workshop | \
with_sparcworks | \
- with_tooltalk | \
+ with_tooltalk | \
with_ldap | \
with_pop | \
with_kerberos | \
verbose | \
extra_verbose | \
const_is_losing | \
- usage_tracking | \
- use_union_type | \
+ usage_tracking | \
+ use_union_type | \
debug | \
use_assertions | \
+ gung_ho | \
use_minimal_tagbits | \
use_indexed_lrecord_implementation | \
- gung_ho | \
- use_assertions | \
memory_usage_stats | \
with_clash_detection | \
with_shlib | \
dnl Make sure the value given was either "yes" or "no".
case "$val" in
y | ye | yes ) val=yes ;;
- n | no ) val=no ;;
+ n | no ) val=no ;;
* ) USAGE_ERROR("The \`--$optname' option requires a boolean value: \`yes' or \`no'.") ;;
esac
- eval "$opt=\"$val\"" ;;
+ eval "$opt=\"$val\"" ;;
dnl Options that take a user-supplied value, as in --puresize=8000000
ldflags | \
puresize | \
cache_file | \
- native_sound_lib | \
+ native_sound_lib| \
site_lisp | \
x_includes | \
x_libraries | \
g | gn | gnu | gnud | gnudb | gnudbm ) with_database_gnudbm=yes ;;
* ) USAGE_ERROR(["The \`--$optname' option value
must be either \`no' or a comma-separated list
- of one or more of \`berkdb', \`dbm', or \`gnudbm'."]) ;;
+ of one or more of \`berkdb' and either \`dbm' or \`gnudbm'."]) ;;
esac
done
if test "$with_database_dbm" = "yes" -a \
eval "$opt=\"$val\""
;;
- dnl XFontSet support?
- "with_xfs" )
- case "$val" in
- y | ye | yes ) val=yes ;;
- n | no | non | none ) val=no ;;
- * ) USAGE_ERROR(["The \`--$optname' option must have one of these values:
- \`yes', or \`no'."]) ;;
- esac
- eval "$opt=\"$val\""
- ;;
-
dnl Mail locking specification
"mail_locking" )
case "$val" in
dnl Has the user specified one of the path options?
prefix | exec_prefix | bindir | datadir | statedir | libdir | \
mandir | infodir | infopath | lispdir | etcdir | lockdir | pkgdir | \
- archlibdir | docdir | package_path )
+ archlibdir | docdir | package_path )
dnl If the value was omitted, get it from the next argument.
if test "$valomitted" = "yes"; then
if test "$#" = 0; then
dnl Has the user asked for some help?
"usage" | "help" ) ${PAGER-more} ${srcdir}/configure.usage; exit 0 ;;
- dnl Has the user specified what toolkit to use for the menubars,
- dnl scrollbar or dialogs?
- "with_menubars" | "with_scrollbars" | "with_dialogs" )
+ dnl Has the user specified the toolkit(s) to use for GUI elements?
+ "with_menubars" | \
+ "with_scrollbars" | \
+ "with_dialogs" )
case "$val" in
l | lu | luc | luci | lucid ) val=lucid ;;
m | mo | mot | moti | motif ) val=motif ;;
eval "$opt=\"$val\""
;;
- dnl Fail on unrecognized arguments.
+ dnl Obsolete legacy argument? Warn, but otherwise ignore.
+ "run_in_place" | \
+ "with_gnu_make" )
+ AC_MSG_WARN([Obsolete option \`--$optname' ignored.])
+ ;;
+
+ dnl Unrecognized option? No mercy for user errors.
* ) USAGE_ERROR("Unrecognized option: $arg") ;;
esac
dnl Assume anything with multiple hyphens is a configuration name.
*-*-*) configuration="$arg" ;;
- dnl Anything else is an error
+ dnl Unrecognized argument? No mercy for user errors.
*) USAGE_ERROR("Unrecognized argument: $arg") ;;
esac
dnl --extra-verbose implies --verbose
test "$extra_verbose" = "yes" && verbose=yes
-dnl Allow use of either ":" or spaces for lists of directories
-define(COLON_TO_SPACE,
- [case "$[$1]" in *:* [)] [$1]="`echo '' $[$1] | sed -e 's/^ //' -e 's/:/ /g'`";; esac])dnl
-COLON_TO_SPACE(site_includes)
-COLON_TO_SPACE(site_libraries)
-COLON_TO_SPACE(site_prefixes)
-COLON_TO_SPACE(site_runtime_libraries)
-
dnl with_x is an obsolete synonym for with_x11
test -n "$with_x" && with_x11="$with_x"
+dnl --with-quantify or --with-purify imply --use-system-malloc
+if test "$with_purify" = "yes" -o "$with_quantify" = "yes"; then
+ test "$with_system_malloc" = "default" && with_system_malloc=yes
+fi
+
dnl --gung-ho=val is a synonym for
dnl --use-minimal-tagbits=val --use-indexed-lrecord-implementation=val
-
if test -n "$gung_ho"; then
test -z "$use_minimal_tagbits" && use_minimal_tagbits="$gung_ho"
test -z "$use_indexed_lrecord_implementation" && \
dnl CDE requires tooltalk
XE_CHECK_FEATURE_DEPENDENCY(cde, tooltalk)
-dnl Ignore useless run-in-place flag
-if test "$run_in_place" = "yes"; then
- AC_MSG_WARN("The --run-in-place option is ignored because it is unnecessary.")
-fi
-
dnl Find the source directory.
case "$srcdir" in
dnl ###########################################################################
if test -z "$configuration"; then
- AC_MSG_CHECKING("host system type")
- dnl Guess the configuration and remove 4th name component, if present.
- if configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess | \
- sed '[s/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/]'` ; then
- AC_MSG_RESULT($configuration)
- else
- AC_MSG_RESULT(unknown)
+ dnl Guess the configuration
+ configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess`
+ if test -z "$configuration"; then
USAGE_ERROR(["XEmacs has not been ported to this host type.
Try explicitly specifying the CONFIGURATION when rerunning configure."])
fi
dnl names of the m/*.h and s/*.h files we should use.
dnl Canonicalize the configuration name.
-AC_CHECKING("the configuration name")
+AC_MSG_CHECKING("host system type")
dnl allow -workshop suffix on configuration name
internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'`
-if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else
- exit $?
-fi
+canonical=`${CONFIG_SHELL-/bin/sh} $srcdir/config.sub "$internal_configuration"`
+XE_STRIP_4TH_COMPONENT(configuration)
+XE_STRIP_4TH_COMPONENT(canonical)
+AC_MSG_RESULT($configuration)
dnl If you add support for a new configuration, add code to this
dnl switch statement to recognize your configuration name and select
m68*-sony-* ) machine=news ;;
mips-sony-* ) machine=news-risc ;;
clipper-* ) machine=clipper ;;
+ arm-* ) machine=arm ;;
+ ns32k-* ) machine=ns32000 ;;
esac
dnl Straightforward OS determination
dnl OpenBSD ports
*-*-openbsd* )
case "${canonical}" in
- alpha*-*-openbsd*) machine=alpha ;;
i386-*-openbsd*) machine=intel386 ;;
m68k-*-openbsd*) machine=hp9000s300 ;;
mipsel-*-openbsd*) machine=pmax ;;
- ns32k-*-openbsd*) machine=ns32000 ;;
- sparc-*-openbsd*) machine=sparc ;;
- vax-*-openbsd*) machine=vax ;;
esac
;;
dnl Linux/68k
m68k-*-linux* ) machine=m68k opsys=linux ;;
- dnl Linux/arm
- arm-*-linux* ) machine=arm opsys=linux ;;
-
esac
if test -z "$machine" -o -z "$opsys"; then
dnl The value of CPP is a quoted variable reference, so we need to do this
dnl to get its actual value...
-CPP=`eval "echo $CPP"`
+CPP=`eval "echo $CPP $CPPFLAGS"`
define(TAB, [ ])dnl
changequote(, )dnl
eval `$CPP -Isrc $tempcname \
set x $[$1]; shift; [$1]=""
while test -n "[$]1"; do
case [$]1 in
- -L | -l | -u ) [$1]="$[$1] [$]1 [$]2"; shift ;;
- -L* | -l* | -u* | -Wl* ) [$1]="$[$1] [$]1" ;;
+ -L | -l | -u ) [$1]="$[$1] [$]1 [$]2"; shift ;;
+ -L* | -l* | -u* | -Wl* | -pg ) [$1]="$[$1] [$]1" ;;
-Xlinker* ) ;;
* ) [$1]="$[$1] -Xlinker [$]1" ;;
esac
dnl Add site and system specific flags to compile and link commands
dnl ---------------------------------------------------------------
-dnl All dirs present in site-prefixes will be searched for include/ and lib/
-dnl subdirs. This can avoid specifying both site-includes and site-libraries.
-dnl Those dirs will take precedence over the standard places, but not over
-dnl site-includes and site-libraries.
-
-dnl --site-prefixes (multiple dirs)
-if test -n "$site_prefixes"; then
- for arg in $site_prefixes; do
- case "$arg" in
- -* ) ;;
- * ) argi="-I${arg}/include" ; argl="-L${arg}/lib" ;;
- esac
- XE_APPEND($argi, c_switch_site)
- XE_APPEND($argl, ld_switch_site)
- done
-fi
+dnl Allow use of either ":" or spaces for lists of directories
+define(COLON_TO_SPACE,
+ [case "$[$1]" in *:* [)] [$1]="`echo '' $[$1] | sed -e 's/^ //' -e 's/:/ /g'`";; esac])dnl
dnl --site-libraries (multiple dirs)
+COLON_TO_SPACE(site_libraries)
if test -n "$site_libraries"; then
for arg in $site_libraries; do
- case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac
+ case "$arg" in
+ -* ) ;;
+ * ) test -d "$arg" || \
+ XE_DIE("Invalid site library \`$arg': no such directory")
+ arg="-L${arg}" ;;
+ esac
XE_APPEND($arg, ld_switch_site)
done
fi
dnl --site-includes (multiple dirs)
+COLON_TO_SPACE(site_includes)
if test -n "$site_includes"; then
for arg in $site_includes; do
- case "$arg" in -* ) ;; * ) arg="-I${arg}" ;; esac
+ case "$arg" in
+ -* ) ;;
+ * ) test -d "$arg" || \
+ XE_DIE("Invalid site include \`$arg': no such directory")
+ arg="-I${arg}" ;;
+ esac
XE_APPEND($arg, c_switch_site)
done
fi
+dnl --site-prefixes (multiple dirs)
+dnl --site-prefixes=dir1:dir2 is a convenient shorthand for
+dnl --site-libraries=dir1/lib:dir2/lib --site-includes=dir1/include:dir2/include
+dnl Site prefixes take precedence over the standard places, but not over
+dnl site-includes and site-libraries.
+COLON_TO_SPACE(site_prefixes)
+if test -n "$site_prefixes"; then
+ for dir in $site_prefixes; do
+ inc_dir="${dir}/include"
+ lib_dir="${dir}/lib"
+ if test ! -d "$dir"; then
+ XE_DIE("Invalid site prefix \`$dir': no such directory")
+ elif test ! -d "$inc_dir"; then
+ XE_DIE("Invalid site prefix \`$dir': no such directory \`$inc_dir'")
+ elif test ! -d "$lib_dir"; then
+ XE_DIE("Invalid site prefix \`$dir': no such directory \`$lib_dir'")
+ else
+ XE_APPEND("-I$inc_dir", c_switch_site)
+ XE_APPEND("-L$lib_dir", ld_switch_site)
+ fi
+ done
+fi
+
dnl GNU software installs by default into /usr/local/{include,lib}
dnl if test -d "/usr/local/include" -a -d "/usr/local/lib"; then
dnl XE_APPEND("-L/usr/local/lib", ld_switch_site)
done
dnl --site-runtime-libraries (multiple dirs)
+COLON_TO_SPACE(site_runtime_libraries)
if test -n "$site_runtime_libraries"; then
LD_RUN_PATH="`echo $site_runtime_libraries | sed -e 's/ */:/g'`"
export LD_RUN_PATH
dnl checks for header files
AC_CHECK_HEADERS(mach/mach.h sys/stropts.h sys/timeb.h sys/time.h unistd.h)
AC_CHECK_HEADERS(utime.h locale.h libgen.h fcntl.h ulimit.h cygwin/version.h)
-AC_CHECK_HEADERS(linux/version.h kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h)
+AC_CHECK_HEADERS(kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h)
AC_HEADER_SYS_WAIT
AC_HEADER_STDC
AC_HEADER_TIME
test "$with_dialogs" != "no" && with_dialogs=msw \
&& XE_ADD_OBJS(dialog-msw.o)
else
- test "$with_scrollbars" != "no" && XE_ADD_OBJS(scrollbar-msw.o)
+ test "$with_scrollbars" != "no" && XE_ADD_OBJS(scrollbar-msw.o)
test "$with_menubars" != "no" && XE_ADD_OBJS(menubar-msw.o)
test "$with_toolbars" != "no" && XE_ADD_OBJS(toolbar-msw.o)
- test "$with_dialogs" != "no" && XE_ADD_OBJS(dialog-msw.o)
+ test "$with_dialogs" != "no" && XE_ADD_OBJS(dialog-msw.o)
fi
- dnl check for our special version of select
+ dnl check for our special version of select
AC_TRY_RUN([#include <fcntl.h>
int main() { return (open("/dev/windows", O_RDONLY, 0) > 0)? 0 : 1; }],
[AC_DEFINE(HAVE_MSG_SELECT)])
fi
dnl Always compile OffiX unless --without-offix is given, no
-dnl X11 support is compiled in, no standard Xmu is avaiable,
+dnl X11 support is compiled in, no standard Xmu is available,
dnl or dragndrop support is disabled
dnl Because OffiX support currently loses when more than one display
dnl is in use, we now disable it by default -slb 07/10/1998.
XE_ADD_OBJS(nas.o)
XE_PREPEND(-laudio, libs_x)
dnl If the nas library does not contain the error jump point,
- dnl then we force safer behaviour.
+ dnl then we force safer behavior.
AC_EGREP_HEADER(AuXtErrorJump,audio/Xtutil.h,,[AC_DEFINE(NAS_NO_ERROR_JUMP)])
esac
dnl Compute lists of Makefiles and subdirs
AC_SUBST(SRC_SUBDIR_DEPS)
XE_APPEND(src, MAKE_SUBDIR)
-internal_makefile_list="Makefile"
+internal_makefile_list="Makefile.in"
SUBDIR_MAKEFILES=''
test -d lock || mkdir lock
for dir in $MAKE_SUBDIR; do
AC_SUBST(RANLIB)
AC_SUBST(dynodump_arch)
-# The default is yes
+dnl Preliminary support for using a different compiler for xemacs itself.
+dnl Useful for building XEmacs with a C++ or 64-bit compiler.
+: ${XEMACS_CC:=$CC}
+AC_SUBST(XEMACS_CC)
+
+
+dnl The default is yes
if test "$with_site_lisp" = "no"; then
AC_DEFINE(INHIBIT_SITE_LISP)
fi
test "$with_i18n3" = "yes" && AC_DEFINE(I18N3)
test "$GCC" = "yes" && AC_DEFINE(USE_GCC)
test "$external_widget" = "yes" && AC_DEFINE(EXTERNAL_WIDGET)
-test "$with_gnu_make" = "yes" && AC_DEFINE(USE_GNU_MAKE)
test "$no_doc_file" = "yes" && AC_DEFINE(NO_DOC_FILE)
dnl test "$const_is_losing" = "yes" && AC_DEFINE(CONST_IS_LOSING)
+test "$with_purify" = "yes" && AC_DEFINE(PURIFY)
test "$with_quantify" = "yes" && AC_DEFINE(QUANTIFY)
test "$with_pop" = "yes" && AC_DEFINE(MAIL_USE_POP)
test "$with_kerberos" = "yes" && AC_DEFINE(KERBEROS)
native ) echo " Compiling in native sound support." ;;
both ) echo " Compiling in both network and native sound support." ;;
esac
-test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously"
+test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously."
test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB."
test "$with_database_dbm" = yes && echo " Compiling in support for DBM."
test "$with_clash_detection" = yes && \
echo " Clash detection will use \"$lockdir\" for locking files."
echo " movemail will use \"$mail_locking\" for locking mail spool files."
-test "$with_pop" = yes && echo " Using POP for mail access"
-test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication"
-test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host"
+test "$with_pop" = yes && echo " Using POP for mail access."
+test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication."
+test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host."
test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects."
test "$use_minimal_tagbits" = yes && echo " Using Lisp_Objects with minimal tagbits."
test "$use_indexed_lrecord_implementation" = yes && echo " Using indexed lrecord implementation."
dnl -----------------------------------
dnl Now generate config.h and Makefiles
dnl -----------------------------------
-
dnl This has to be called in order for this variable to get into config.status
AC_SUBST(internal_makefile_list)
# Remove any trailing slashes in these variables.
ac_output_files="$ac_output_files src/paths.h lib-src/config.values"
AC_OUTPUT($ac_output_files,
-[for dir in $MAKE_SUBDIR; do
- echo creating $dir/Makefile
+[for dir in . $MAKE_SUBDIR; do
(
-changequote(<<, >>)dnl
cd $dir
rm -f junk.c
< Makefile.in \
sed -e '/^# Generated/d' \
-e 's%/\*\*/#.*%%' \
-e 's/^ *# */#/' \
+dnl Delete Makefile.in.in comment lines
-e '/^##/d' \
+dnl Pass through CPP directives unchanged
-e '/^#/ {
p
d
-}' -e '/./ {
-s/\([\"]\)/\\\1/g
+}' \
+dnl Quote other lines to protect from CPP substitution
+ -e '/./ {
+s/\([[\"]]\)/\\\1/g
s/^/"/
s/$/"/
}' > junk.c;
- $CPP -I. -I${top_srcdir}/src $CPPFLAGS junk.c > junk.cpp;
- < junk.cpp \
- sed -e 's/^#.*//' \
- -e 's/^[ TAB][ TAB]*$//' \
- -e 's/^ /TAB/' \
- | sed -n -e '/^..*$/p' \
- | sed '/^"/ {
-s/\\\([\"]\)/\1/g
-s/^[ TAB]*"//
-s/"[ TAB]*$//
-}' > Makefile.new
+
+dnl Create a GNUmakefile and Makefile from Makefile.in.
+
+changequote(<<,>>)dnl
+dnl CPP_MAKEFILE(CPPFLAGS,filename)
+define(<<CPP_MAKEFILE>>,
+echo creating $dir/<<$2>>
+$CPP -I. -I${top_srcdir}/src <<$1>> junk.c \
+dnl Delete line directives inserted by $CPP
+ | sed -e 's/^\#.*//' \
+dnl Delete spurious blanks inserted by $CPP
+ -e 's/^[ TAB][ TAB]*$//'\
+ -e 's/^ /TAB/' \
+dnl Delete blank lines
+ | sed -n -e '/^..*$/p' \
+dnl Restore lines quoted above to original contents.
+ | sed '/^\"/ {
+ s/\\\([\"]\)/\1/g
+ s/^[ TAB]*\"//
+ s/\"[ TAB]*$//
+}' > Makefile.new
chmod 444 Makefile.new
- mv -f Makefile.new Makefile
- rm -f junk.c junk.cpp
-changequote([, ])dnl
-)
+ mv -f Makefile.new <<$2>>
+)dnl CPP_MAKEFILE
+
+ CPP_MAKEFILE(,Makefile)
+ CPP_MAKEFILE(-DUSE_GNU_MAKE,GNUmakefile)
+changequote([,])dnl
+ rm -f junk.c
+ )
done
dnl Append AC_DEFINE information to lib-src/config.values
],
[CPP="$CPP"
- CPPFLAGS="$CPPFLAGS"
top_srcdir="$srcdir"
MAKE_SUBDIR="$MAKE_SUBDIR"
-])
+])dnl
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);
+1998-12-05 XEmacs Build Bot <builds@cvs.xemacs.org>
+
+ * XEmacs 21.2.5 is released
+
+1998-12-05 SL Baur <steve@altair.xemacs.org>
+
+ * files.el (binary-file-regexps): regexp-opt is not available at
+ bytecompile time.
+
+1998-11-30 Martin Buchholz <martin@xemacs.org>
+
+ * x-win-xfree86.el:
+ * x-win-sun.el (x-win-init-sun):
+ * x-win-sun.el:
+ * x-mouse.el (mouse-track-and-copy-to-cutbuffer):
+ * x-iso8859-1.el:
+ * x-init.el (init-post-x-win):
+ * x-init.el (init-pre-x-win):
+ * x-init.el (x-initialize-compose):
+ * x-init.el:
+ * x-compose.el:
+ * winnt.el:
+ * widget.el:
+ * wid-edit.el (widget-glyph-click):
+ * wid-edit.el (widget-glyph-find):
+ * wid-edit.el (widget-type):
+ * view-less.el (view-buffer-other-window):
+ * very-early-lisp.el:
+ * version.el:
+ * toolbar.el:
+ * toolbar-items.el:
+ * term/sun.el (suntool-map):
+ * term/sun-mouse.el:
+ * term/internal.el:
+ * syntax.el (modify-syntax-entry):
+ * symbol-syntax.el:
+ * subr.el:
+ * startup.el (lock-directory):
+ * simple.el (set-comment-column):
+ * simple.el (backward-delete-char-untabify):
+ * shadow.el (find-emacs-lisp-shadows):
+ * shadow.el:
+ * setup-paths.el (paths-construct-info-path):
+ * select.el (cut-copy-clear-internal):
+ * process.el (call-process-region):
+ * process.el (start-process-shell-command):
+ * process.el:
+ * paths.el (rmail-spool-directory):
+ * paragraphs.el (use-hard-newlines):
+ * package-get.el (package-get-dependencies):
+ * package-admin.el (package-admin-delete-binary-package):
+ * obsolete.el (truncate-string):
+ * obsolete.el (store-substring):
+ * mouse.el (default-mouse-track-maybe-own-selection):
+ * mouse.el (mouse-yank-at-point):
+ * modeline.el:
+ * modeline.el (mouse-drag-modeline):
+ * minibuf.el (read-directory-name-internal):
+ * minibuf.el (read-file-name-internal):
+ * minibuf.el (read-file-name-internal-1):
+ * minibuf.el (read-file-name-2):
+ * minibuf.el (exact-minibuffer-completion-p):
+ * minibuf.el (read-from-minibuffer):
+ * minibuf.el:
+ * menubar.el (check-menu-syntax):
+ * map-ynp.el (map-y-or-n-p):
+ * make-docfile.el (docfile-out-of-date):
+ * loadup.el ((member "run-temacs" command-line-args)):
+ * loadup.el ((member "no-site-file" command-line-args)):
+ * loadup.el (really-early-error-handler):
+ * loadup.el:
+ * loadhist.el:
+ * loaddefs.el:
+ * lisp-mnt.el (lm-verify):
+ * lib-complete.el (lib-complete:cache-completions):
+ * lib-complete.el (library-all-completions):
+ * itimer.el (itimer-run-expired-timers):
+ * info.el (Info-mode):
+ * info.el (Info-insert-file-contents):
+ * info.el (Info-rebuild-dir):
+ * info.el (Info-build-dir-anew):
+ * info.el (Info-parse-dir-entries):
+ * info.el (Info-dir-outdated-p):
+ * info.el (Info-insert-dir):
+ * info.el (info-xref):
+ * info.el:
+ * hyper-apropos.el (hyper-apropos-get-doc):
+ * hyper-apropos.el (hyper-describe-face):
+ * hyper-apropos.el (hyper-apropos-mode):
+ * hyper-apropos.el:
+ * help.el (list-processes):
+ * help.el:
+ * gnuserv.el:
+ * font.el (mswindows-font-create-name):
+ * font.el (font-default-font-for-device):
+ * font.el (x-font-create-object):
+ * font.el (font-registry):
+ * font.el:
+ * font-lock.el (font-lock-keywords):
+ * font-lock.el:
+ * finder.el (finder-compile-keywords):
+ * find-paths.el (paths-find-recursive-path):
+ * fill.el (set-justification-center):
+ * fill.el (fill-region-as-paragraph):
+ * files.el (insert-directory):
+ * files.el (wildcard-to-regexp):
+ * files.el (recover-file):
+ * files.el (basic-save-buffer):
+ * files.el (delete-auto-save-file-if-necessary):
+ * files.el (file-relative-name):
+ * files.el (backup-extract-version):
+ * files.el (backup-buffer):
+ * files.el (set-visited-file-name):
+ * files.el (set-auto-mode):
+ * files.el (interpreter-mode-alist):
+ * files.el:
+ * files.el (find-file-noselect):
+ * files.el (abbreviate-file-name):
+ * files.el (parse-colon-path):
+ * files.el (directory-abbrev-alist):
+ * etags.el (visit-tags-table-buffer):
+ * easymenu.el (easy-menu-define):
+ * dragdrop.el (experimental-dragdrop-drag):
+ * dragdrop.el (dragdrop-drop-do-functions):
+ * dragdrop.el (dragdrop-drop-at-point):
+ * disass.el (disassemble-1):
+ * disass.el (disassemble-internal):
+ * disass.el (disassemble):
+ * disass.el:
+ * derived.el (derived-mode-init-mode-variables):
+ * derived.el (define-derived-mode):
+ * custom.el (defgroup):
+ * cus-edit.el (custom-quote):
+ * config.el:
+ * code-process.el (open-network-stream):
+ * code-process.el (start-process):
+ * code-process.el (call-process-region):
+ * code-process.el (call-process):
+ * code-process.el:
+ * code-files.el (insert-file-contents):
+ * code-files.el:
+ * code-files.el (buffer-file-coding-system-for-read):
+ * cmdloop.el (yes-or-no-p-minibuf):
+ * cl.el:
+ * cl-macs.el:
+ * cl-extra.el:
+ * callers-of-rpt.el (make-caller-report):
+ * callers-of-rpt.el:
+ * bytecomp.el (batch-byte-recompile-directory):
+ * bytecomp.el (batch-byte-compile-1):
+ * bytecomp.el (batch-byte-compile):
+ * bytecomp.el (display-call-tree):
+ * bytecomp.el (byte-compile-insert):
+ * bytecomp.el (byte-compile-two-args-19->20):
+ * bytecomp.el (byte-compile-variable-ref):
+ * bytecomp.el (byte-compile-form):
+ * bytecomp.el (byte-compile-top-level-body):
+ * bytecomp.el (byte-compile-out-toplevel):
+ * bytecomp.el (byte-compile-byte-code-maker):
+ * bytecomp.el (byte-compile-file-form-defmumble):
+ * bytecomp.el (byte-compile-file-form):
+ * bytecomp.el (byte-compile-keep-pending):
+ * bytecomp.el (byte-compile-insert-header):
+ * bytecomp.el (byte-compile-from-buffer):
+ * bytecomp.el (byte-compile-file):
+ * bytecomp.el (byte-recompile-file):
+ * bytecomp.el (byte-compile-close-variables):
+ * bytecomp.el (byte-compile-warn-about-unused-variables):
+ * bytecomp.el (byte-compile-warn-about-unresolved-functions):
+ * bytecomp.el (byte-compiler-legal-options):
+ * bytecomp.el (byte-compile-lapcode):
+ * bytecomp.el (byte-optimize-log):
+ * bytecomp.el ((fboundp 'defsubst)):
+ * bytecomp.el:
+ * bytecomp-runtime.el:
+ * byte-optimize.el (byte-optimize-apply):
+ * byte-optimize.el (car):
+ * byte-optimize.el (byte-optimize-form):
+ * byte-optimize.el (byte-optimize-form-code-walker):
+ * byte-optimize.el:
+ * build-report.el (build-report-insert-installation-file):
+ * build-report.el (build-report):
+ * auto-show.el:
+ * apropos.el (apropos-documentation):
+ - mega patch
+ - clean up byte-compile warnings
+ - remove unused variables
+ - Use common lisp style hashtable functions
+ - byte compiler cleanup
+ - use #'(lambda ...) instead of '(lambda ...) or (function (lambda ...))
+ - remove old backquote syntax usage
+ - move some cl functionality into C for speed.
+ - remove last remaining VMS support
+ - spelling fixes
+ - implement last, butlast, nbutlast, copy-list in C.
+ - new macro ignore-file-errors, similar to ignore-errors
+ (ignore-file-errors (delete-file "foo"))
+ - get frequent garbage collection during loadup.el by tweaking
+ gc-cons-threshold, rather than explicitly calling garbage-collect
+ - default delete-key-deletes-forward to `t'.
+
1998-11-28 SL Baur <steve@altair.xemacs.org>
* XEmacs 21.2-beta4 is released.
mswindows-make-font-bold / -bold-italic: Supplied device was
not being passed into call to mswindows-find-smaller-font.
-1998-09-10 Björn Torkelsson <torkel@hpc2n.umu.se>
+1998-09-10 Bjrn Torkelsson <torkel@hpc2n.umu.se>
* package-get.el (package-get-remote): Fix the path where to find
the packages on xemacs.org.
(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))
;; Subsequently modified by RMS and others.
-(defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96."))
+(defconst byte-compile-version (purecopy "2.26 XEmacs; 1998-10-07."))
;; This file is part of XEmacs.
;;; 'unresolved (calls to unknown functions)
;;; 'callargs (lambda calls with args that don't
;;; match the lambda's definition)
+;;; 'subr-callargs (calls to subrs with args that
+;;; don't match the subr's definition)
;;; 'redefine (function cell redefined from
;;; a macro to a lambda or vice versa,
;;; or redefined to take other args)
;;; buffer, and that buffer is modified, you are asked whether you want
;;; to save the buffer before compiling.
;;;
-;;; o You can add this to /etc/magic to make file(1) recognise the files
+;;; o You can add this to /etc/magic to make file(1) recognize the files
;;; generated by this compiler:
;;;
;;; 0 string ;ELC GNU Emacs Lisp compiled file,
be hard-coded into bytecomp when it compiles itself. If the compiler itself
is compiled with optimization, this causes a speedup.")
- (cond (byte-compile-single-version
- (defmacro byte-compile-single-version () t)
- (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond))))
- (t
- (defmacro byte-compile-single-version () nil)
- (defmacro byte-compile-version-cond (cond) cond)))
+ (cond
+ (byte-compile-single-version
+ (defmacro byte-compile-single-version () t)
+ (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond))))
+ (t
+ (defmacro byte-compile-single-version () nil)
+ (defmacro byte-compile-version-cond (cond) cond)))
)
-(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms)
- (purecopy "\\.EL\\(;[0-9]+\\)?$")
- (purecopy "\\.el$"))
+(defvar emacs-lisp-file-regexp (purecopy "\\.el$")
"*Regexp which matches Emacs Lisp source files.
You may want to redefine `byte-compile-dest-file' if you change this.")
(funcall handler 'byte-compiler-base-file-name filename)
filename)))
-(or (fboundp 'byte-compile-dest-file)
- ;; The user may want to redefine this along with emacs-lisp-file-regexp,
- ;; so only define it if it is undefined.
- (defun byte-compile-dest-file (filename)
- "Convert an Emacs Lisp source file name to a compiled file name."
- (setq filename (byte-compiler-base-file-name filename))
- (setq filename (file-name-sans-versions filename))
- (cond ((eq system-type 'vax-vms)
- (concat (substring filename 0 (string-match ";" filename)) "c"))
- ((string-match emacs-lisp-file-regexp filename)
- (concat (substring filename 0 (match-beginning 0)) ".elc"))
- (t (concat filename ".elc")))))
+(unless (fboundp 'byte-compile-dest-file)
+ ;; The user may want to redefine this along with emacs-lisp-file-regexp,
+ ;; so only define it if it is undefined.
+ (defun byte-compile-dest-file (filename)
+ "Convert an Emacs Lisp source file name to a compiled file name."
+ (setq filename (byte-compiler-base-file-name filename))
+ (setq filename (file-name-sans-versions filename))
+ (if (string-match emacs-lisp-file-regexp filename)
+ (concat (substring filename 0 (match-beginning 0)) ".elc")
+ (concat filename ".elc"))))
;; This can be the 'byte-compile property of any symbol.
(autoload 'byte-compile-inline-expand "byte-optimize")
;; disassembler. The disassembler just requires 'byte-compile, but
;; that doesn't define this function, so this seems to be a reasonable
;; thing to do.
-(autoload 'byte-decompile-bytecode "byte-opt")
+(autoload 'byte-decompile-bytecode "byte-optimize")
(defvar byte-compile-verbose
(and (not noninteractive) (> (device-baud-rate) search-slow-speed))
;; byte-compile-warning-types in FSF.
(defvar byte-compile-default-warnings
- '(redefine callargs free-vars unresolved unused-vars obsolete)
+ '(redefine callargs subr-callargs free-vars unresolved unused-vars obsolete)
"*The warnings used when byte-compile-warnings is t.")
(defvar byte-compile-warnings t
unused-vars references to non-global variables bound but not referenced.
unresolved calls to unknown functions.
callargs lambda calls with args that don't match the definition.
+ subr-callargs calls to subrs with args that don't match the definition.
redefine function cell redefined from a macro to a lambda or vice
versa, or redefined to take a different number of arguments.
obsolete use of an obsolete function or variable.
(defvar byte-compile-generate-call-tree nil
"*Non-nil means collect call-graph information when compiling.
-This records functions were called and from where.
+This records functions that were called and from where.
If the value is t, compilation displays the call graph when it finishes.
If the value is neither t nor nil, compilation asks you whether to display
the graph.
(defvar byte-compile-free-references)
(defvar byte-compile-free-assignments)
+(defvar debug-issue-ebola-notices)
(defvar byte-compiler-error-flag)
"to examine top-of-stack, jump and don't pop it if it's nil,
otherwise pop it")
(byte-defop 134 -1 byte-goto-if-not-nil-else-pop
- "to examine top-of-stack, jump and don't pop it if it's non nil,
+ "to examine top-of-stack, jump and don't pop it if it's non-nil,
otherwise pop it")
(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'")
(error "Non-symbolic opcode `%s'" op))
((eq op 'TAG)
(setcar off pc)
- (setq patchlist (cons off patchlist)))
+ (push off patchlist))
((memq op byte-goto-ops)
(setq pc (+ pc 3))
(setq bytes (cons (cons pc (cdr off))
(cons nil
(cons (symbol-value op) bytes))))
- (setq patchlist (cons bytes patchlist)))
+ (push bytes patchlist))
(t
(setq bytes
(cond ((cond ((consp off)
(defvar byte-compile-dest-file nil)
(defmacro byte-compile-log (format-string &rest args)
- (list 'and
- 'byte-optimize
- '(memq byte-optimize-log '(t source))
- (list 'let '((print-escape-newlines t)
- (print-level 4)
- (print-length 4))
- (list 'byte-compile-log-1
- (cons 'format
- (cons format-string
- (mapcar
- '(lambda (x)
- (if (symbolp x) (list 'prin1-to-string x) x))
- args)))))))
-
-(defconst byte-compile-last-warned-form nil)
+ `(when (and byte-optimize (memq byte-optimize-log '(t source)))
+ (let ((print-escape-newlines t)
+ (print-level 4)
+ (print-length 4))
+ (byte-compile-log-1 (format ,format-string ,@args)))))
+
+(defconst byte-compile-last-warned-form 'nothing)
;; Log a message STRING in *Compile-Log*.
;; Also log the current function and file if not already done.
(defun byte-compile-log-1 (string &optional fill)
- (let ((this-form (or byte-compile-current-form "toplevel forms")))
- (cond
- (noninteractive
- (if (or byte-compile-current-file
- (and byte-compile-last-warned-form
- (not (eq this-form byte-compile-last-warned-form))))
- (message
- (format "While compiling %s%s:"
- this-form
- (if byte-compile-current-file
- (if (stringp byte-compile-current-file)
- (concat " in file " byte-compile-current-file)
- (concat " in buffer "
- (buffer-name byte-compile-current-file)))
- ""))))
- (message " %s" string))
- (t
- (save-excursion
- (set-buffer (get-buffer-create "*Compile-Log*"))
+ (let* ((this-form (or byte-compile-current-form "toplevel forms"))
+ (while-compiling-msg
+ (when (or byte-compile-current-file
+ (not (eq this-form byte-compile-last-warned-form)))
+ (format
+ "While compiling %s%s:"
+ this-form
+ (cond
+ ((stringp byte-compile-current-file)
+ (concat " in file " byte-compile-current-file))
+ ((bufferp byte-compile-current-file)
+ (concat " in buffer "
+ (buffer-name byte-compile-current-file)))
+ (""))))))
+ (if noninteractive
+ (progn
+ (when while-compiling-msg (message "%s" while-compiling-msg))
+ (message " %s" string))
+ (with-current-buffer (get-buffer-create "*Compile-Log*")
(goto-char (point-max))
- (cond ((or byte-compile-current-file
- (and byte-compile-last-warned-form
- (not (eq this-form byte-compile-last-warned-form))))
- (if byte-compile-current-file
- (insert "\n\^L\n" (current-time-string) "\n"))
- (insert "While compiling "
- (if (stringp this-form) this-form
- (format "%s" this-form)))
- (if byte-compile-current-file
- (if (stringp byte-compile-current-file)
- (insert " in file " byte-compile-current-file)
- (insert " in buffer "
- (buffer-name byte-compile-current-file))))
- (insert ":\n")))
+ (when byte-compile-current-file
+ (when (> (point-max) (point-min))
+ (insert "\n\^L\n"))
+ (insert (current-time-string) "\n"))
+ (when while-compiling-msg (insert while-compiling-msg "\n"))
(insert " " string "\n")
- (if (and fill (not (string-match "\n" string)))
- (let ((fill-prefix " ")
- (fill-column 78))
- (fill-paragraph nil)))
- )))
- (setq byte-compile-current-file nil
- byte-compile-last-warned-form this-form)))
+ (when (and fill (not (string-match "\n" string)))
+ (let ((fill-prefix " ")
+ (fill-column 78))
+ (fill-paragraph nil)))))
+ (setq byte-compile-current-file nil)
+ (setq byte-compile-last-warned-form this-form)))
;; Log the start of a file in *Compile-Log*, and mark it as done.
;; But do nothing in batch mode.
(defun byte-compile-log-file ()
- (and byte-compile-current-file (not noninteractive)
- (save-excursion
- (set-buffer (get-buffer-create "*Compile-Log*"))
- (goto-char (point-max))
- (insert "\n\^L\nCompiling "
- (if (stringp byte-compile-current-file)
- (concat "file " byte-compile-current-file)
- (concat "buffer " (buffer-name byte-compile-current-file)))
- " at " (current-time-string) "\n")
- (setq byte-compile-current-file nil))))
+ (when (and byte-compile-current-file (not noninteractive))
+ (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (when (> (point-max) (point-min))
+ (goto-char (point-max))
+ (insert "\n\^L\n"))
+ (insert "Compiling "
+ (if (stringp byte-compile-current-file)
+ (concat "file " byte-compile-current-file)
+ (concat "buffer " (buffer-name byte-compile-current-file)))
+ " at " (current-time-string) "\n")
+ (setq byte-compile-current-file nil))))
(defun byte-compile-warn (format &rest args)
(setq format (apply 'format format args))
(verbose byte-compile-verbose (t nil) val)
(new-bytecodes byte-compile-new-bytecodes (t nil) val)
(warnings byte-compile-warnings
- ((callargs redefine free-vars unused-vars unresolved))
+ ((callargs subr-callargs redefine free-vars unused-vars unresolved))
val)))
;; XEmacs addition
nil)
(defun byte-compile-defvar-p (var)
- ;; Whether the byte compiler thinks that nonexical references to this
+ ;; Whether the byte compiler thinks that non-lexical references to this
;; variable are ok.
(or (globally-boundp var)
(let ((rest byte-compile-bound-variables))
;; have (declare (ignore x)) yet; and second, inline
;; expansion produces forms like
;; ((lambda (arg) (byte-code "..." [arg])) x)
- ;; which we can't (ok, well, don't) recognise as
+ ;; which we can't (ok, well, don't) recognize as
;; containing a reference to arg, so every inline
;; expansion would generate a warning. (If we had
;; `ignore' then inline expansion could emit an
(setq unreferenced (cdr unreferenced)))))
\f
+(defmacro byte-compile-constant-symbol-p (symbol)
+ `(or (keywordp ,symbol) (memq ,symbol '(nil t))))
+
(defmacro byte-compile-constp (form)
;; Returns non-nil if FORM is a constant.
- (` (cond ((consp (, form)) (eq (car (, form)) 'quote))
- ((not (symbolp (, form))))
- ((keywordp (, form)))
- ((memq (, form) '(nil t))))))
+ `(cond ((consp ,form) (eq (car ,form) 'quote))
+ ((symbolp ,form) (byte-compile-constant-symbol-p ,form))
+ (t)))
(defmacro byte-compile-close-variables (&rest body)
`(let
byte-compile-default-warnings
byte-compile-warnings))
(byte-compile-file-domain nil)
+
+ ;; We reserve the right to compare ANY objects for equality.
+ (debug-issue-ebola-notices -42)
)
(prog1
(progn ,@body)
(byte-compile-warn-about-unused-variables)))))
-(defvar byte-compile-warnings-point-max nil)
(defmacro displaying-byte-compile-warnings (&rest body)
- `(let ((byte-compile-warnings-point-max byte-compile-warnings-point-max))
- ;; Log the file name.
+ `(let* ((byte-compile-log-buffer (get-buffer-create "*Compile-Log*"))
+ (byte-compile-point-max-prev (point-max byte-compile-log-buffer)))
+ ;; Log the file name or buffer name.
(byte-compile-log-file)
;; Record how much is logged now.
;; We will display the log buffer if anything more is logged
;; before the end of BODY.
- (or byte-compile-warnings-point-max
- (save-excursion
- (set-buffer (get-buffer-create "*Compile-Log*"))
- (setq byte-compile-warnings-point-max (point-max))))
- (unwind-protect
- (condition-case error-info
- (progn ,@body)
- (error
- (byte-compile-report-error error-info)))
- (save-excursion
- ;; If there were compilation warnings, display them.
- (set-buffer "*Compile-Log*")
- (if (= byte-compile-warnings-point-max (point-max))
- nil
- (if temp-buffer-show-function
- (let ((show-buffer (get-buffer-create "*Compile-Log-Show*")))
- (save-excursion
- (set-buffer show-buffer)
- (setq buffer-read-only nil)
- (erase-buffer))
- (copy-to-buffer show-buffer
- (save-excursion
- (goto-char byte-compile-warnings-point-max)
- (forward-line -1)
- (point))
- (point-max))
- (funcall temp-buffer-show-function show-buffer))
- (select-window
- (prog1 (selected-window)
- (select-window (display-buffer (current-buffer)))
- (goto-char byte-compile-warnings-point-max)
- (recenter 1)))))))))
+ (defvar byte-compile-warnings-beginning)
+ (let ((byte-compile-warnings-beginning
+ (if (boundp 'byte-compile-warnings-beginning)
+ byte-compile-warnings-beginning
+ (point-max byte-compile-log-buffer))))
+
+ (unwind-protect
+ (condition-case error-info
+ (progn ,@body)
+ (error
+ (byte-compile-report-error error-info)))
+
+ ;; Always set point in log to start of interesting output.
+ (with-current-buffer byte-compile-log-buffer
+ (let ((show-begin
+ (progn (goto-char byte-compile-point-max-prev)
+ (skip-chars-forward "\^L\n")
+ (point))))
+ ;; If there were compilation warnings, display them.
+ (if temp-buffer-show-function
+ (let ((show-buffer (get-buffer-create "*Compile-Log-Show*")))
+ ;; Always clean show-buffer, even when not displaying it,
+ ;; so that misleading previous messages aren't left around.
+ (with-current-buffer show-buffer
+ (setq buffer-read-only nil)
+ (erase-buffer))
+ (copy-to-buffer show-buffer show-begin (point-max))
+ (when (< byte-compile-warnings-beginning (point-max))
+ (funcall temp-buffer-show-function show-buffer)))
+ (when (< byte-compile-warnings-beginning (point-max))
+ (select-window
+ (prog1 (selected-window)
+ (select-window (display-buffer (current-buffer)))
+ (goto-char show-begin)
+ (recenter 1)))))))))))
\f
;;;###autoload
(y-or-n-p (concat "Compile " filename "? "))))))
(byte-compile-file filename))))
-(defvar kanji-flag nil)
-
;;;###autoload
(defun byte-compile-file (filename &optional load)
"Compile a file of Lisp code named FILENAME into a file of byte code.
(message "Compiling %s..." filename))
(let (;;(byte-compile-current-file (file-name-nondirectory filename))
(byte-compile-current-file filename)
- (debug-issue-ebola-notices 0) ; Hack -slb
target-file input-buffer output-buffer
byte-compile-dest-file)
(setq target-file (byte-compile-dest-file filename))
(set-buffer output-buffer)
(goto-char (point-max))
(insert "\n") ; aaah, unix.
- (let ((vms-stmlf-recfm t))
- (setq target-file (byte-compile-dest-file filename))
- (or byte-compile-overwrite-file
- (condition-case ()
- (delete-file target-file)
- (error nil)))
- (if (file-writable-p target-file)
- (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki
- (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt))
- (setq buffer-file-type t))
- (write-region 1 (point-max) target-file))
- ;; This is just to give a better error message than write-region
- (signal 'file-error
- (list "Opening output file"
- (if (file-exists-p target-file)
- "cannot overwrite file"
- "directory not writable or nonexistent")
- target-file)))
- (or byte-compile-overwrite-file
- (condition-case ()
- (set-file-modes target-file (file-modes filename))
- (error nil))))
+ (setq target-file (byte-compile-dest-file filename))
+ (unless byte-compile-overwrite-file
+ (ignore-file-errors (delete-file target-file)))
+ (if (file-writable-p target-file)
+ (progn
+ (when (memq system-type '(ms-dos windows-nt))
+ (defvar buffer-file-type)
+ (setq buffer-file-type t))
+ (write-region 1 (point-max) target-file))
+ ;; This is just to give a better error message than write-region
+ (signal 'file-error
+ (list "Opening output file"
+ (if (file-exists-p target-file)
+ "cannot overwrite file"
+ "directory not writable or nonexistent")
+ target-file)))
+ (or byte-compile-overwrite-file
+ (condition-case ()
+ (set-file-modes target-file (file-modes filename))
+ (error nil)))
(kill-buffer (current-buffer)))
(if (and byte-compile-generate-call-tree
(or (eq t byte-compile-generate-call-tree)
;; Compile the forms from the input buffer.
(while (progn
- (while (progn (skip-chars-forward " \t\n\^l")
+ (while (progn (skip-chars-forward " \t\n\^L")
(looking-at ";"))
(forward-line 1))
(not (eobp)))
;; extended characters are output properly and distinguished properly.
;; Otherwise, use `no-conversion' for maximum portability with non-Mule
;; Emacsen.
- (if (featurep 'mule)
- (if (save-excursion
- (set-buffer byte-compile-inbuffer)
- (goto-char (point-min))
- ;; mrb- There must be a better way than skip-chars-forward
- (skip-chars-forward (concat (char-to-string 0) "-"
- (char-to-string 255)))
- (eq (point) (point-max)))
- (setq buffer-file-coding-system 'no-conversion)
- (insert "(require 'mule)\n;;;###coding system: escape-quoted\n")
- (setq buffer-file-coding-system 'escape-quoted)
- ;; Lazy loading not yet implemented for MULE files
- ;; mrb - Fix this someday.
- (save-excursion
+ (when (featurep 'mule)
+ (defvar buffer-file-coding-system)
+ (if (save-excursion
(set-buffer byte-compile-inbuffer)
- (setq byte-compile-dynamic nil
- byte-compile-dynamic-docstrings nil))
- ;;(external-debugging-output (prin1-to-string (buffer-local-variables))))
- ))
+ (goto-char (point-min))
+ ;; mrb- There must be a better way than skip-chars-forward
+ (skip-chars-forward (concat (char-to-string 0) "-"
+ (char-to-string 255)))
+ (eq (point) (point-max)))
+ (setq buffer-file-coding-system 'no-conversion)
+ (insert "(require 'mule)\n;;;###coding system: escape-quoted\n")
+ (setq buffer-file-coding-system 'escape-quoted)
+ ;; #### Lazy loading not yet implemented for MULE files
+ ;; mrb - Fix this someday.
+ (save-excursion
+ (set-buffer byte-compile-inbuffer)
+ (setq byte-compile-dynamic nil
+ byte-compile-dynamic-docstrings nil))
+ ;;(external-debugging-output (prin1-to-string (buffer-local-variables))))
+ ))
)
(nthcdr 300 byte-compile-output)
(byte-compile-flush-pending))
(funcall handler form)
- (if for-effect
- (byte-compile-discard)))
+ (when for-effect
+ (byte-compile-discard)))
(byte-compile-form form t))
nil)
(byte-compile-file-form form)))))
;; Functions and variables with doc strings must be output separately,
-;; so make-docfile can recognise them. Most other things can be output
+;; so make-docfile can recognize them. Most other things can be output
;; as byte-code.
(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
(cons (list name nil nil) byte-compile-call-tree))))
(setq byte-compile-current-form name) ; for warnings
- (if (memq 'redefine byte-compile-warnings)
- (byte-compile-arglist-warn form macrop))
- (if byte-compile-verbose
- (message "Compiling %s... (%s)"
- ;; #### filename used free
- (if filename (file-name-nondirectory filename) "")
- (nth 1 form)))
+ (when (memq 'redefine byte-compile-warnings)
+ (byte-compile-arglist-warn form macrop))
+ (defvar filename) ; #### filename used free
+ (when byte-compile-verbose
+ (message "Compiling %s... (%s)"
+ (if filename (file-name-nondirectory filename) "")
+ (nth 1 form)))
(cond (that-one
- (if (and (memq 'redefine byte-compile-warnings)
- ;; hack hack: don't warn when compiling the stubs in
- ;; bytecomp-runtime...
- (not (assq (nth 1 form)
- byte-compile-initial-macro-environment)))
- (byte-compile-warn
- "%s defined multiple times, as both function and macro"
- (nth 1 form)))
+ (when (and (memq 'redefine byte-compile-warnings)
+ ;; hack hack: don't warn when compiling the stubs in
+ ;; bytecomp-runtime...
+ (not (assq (nth 1 form)
+ byte-compile-initial-macro-environment)))
+ (byte-compile-warn
+ "%s defined multiple times, as both function and macro"
+ (nth 1 form)))
(setcdr that-one nil))
(this-one
- (if (and (memq 'redefine byte-compile-warnings)
- ;; hack: don't warn when compiling the magic internal
- ;; byte-compiler macros in bytecomp-runtime.el...
- (not (assq (nth 1 form)
- byte-compile-initial-macro-environment)))
- (byte-compile-warn "%s %s defined multiple times in this file"
- (if macrop "macro" "function")
- (nth 1 form))))
+ (when (and (memq 'redefine byte-compile-warnings)
+ ;; hack: don't warn when compiling the magic internal
+ ;; byte-compiler macros in bytecomp-runtime.el...
+ (not (assq (nth 1 form)
+ byte-compile-initial-macro-environment)))
+ (byte-compile-warn "%s %s defined multiple times in this file"
+ (if macrop "macro" "function")
+ (nth 1 form))))
((and (fboundp name)
(or (subrp (symbol-function name))
(eq (car-safe (symbol-function name))
(if macrop "macro" "function")))
;; shadow existing definition
(set this-kind
- (cons (cons name nil) (symbol-value this-kind))))
- )
+ (cons (cons name nil) (symbol-value this-kind)))))
(let ((body (nthcdr 3 form)))
(if (and (stringp (car body))
(symbolp (car-safe (cdr-safe body)))
(let* ((interactive (assq 'interactive (cdr (cdr fun)))))
(nconc (list 'make-byte-code
(list 'quote (nth 1 fun)) ;arglist
- (nth 1 tmp) ;bytes
- (nth 2 tmp) ;consts
- (nth 3 tmp)) ;depth
+ (nth 1 tmp) ;instructions
+ (nth 2 tmp) ;constants
+ (nth 3 tmp)) ;stack-depth
(cond ((stringp (nth 2 fun))
- (list (nth 2 fun))) ;doc
+ (list (nth 2 fun))) ;docstring
(interactive
(list nil)))
(cond (interactive
(let* ((arglist (nth 1 fun))
(byte-compile-bound-variables
(let ((new-bindings
- (mapcar (function (lambda (x)
- (cons x byte-compile-arglist-bit)))
+ (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit))
(and (memq 'free-vars byte-compile-warnings)
(delq '&rest (delq '&optional
(copy-sequence arglist)))))))
(prog1 (car body)
(setq body (cdr body)))))
(int (assq 'interactive body)))
- (let ((rest arglist))
- (while rest
- (cond ((not (symbolp (car rest)))
- (byte-compile-warn "non-symbol in arglist: %s"
- (prin1-to-string (car rest))))
- ((memq (car rest) '(t nil))
- (byte-compile-warn "constant in arglist: %s" (car rest)))
- ((and (char= ?\& (aref (symbol-name (car rest)) 0))
- (not (memq (car rest) '(&optional &rest))))
- (byte-compile-warn "unrecognised `&' keyword in arglist: %s"
- (car rest))))
- (setq rest (cdr rest))))
+ (dolist (arg arglist)
+ (cond ((not (symbolp arg))
+ (byte-compile-warn "non-symbol in arglist: %S" arg))
+ ((byte-compile-constant-symbol-p arg)
+ (byte-compile-warn "constant symbol in arglist: %s" arg))
+ ((and (char= ?\& (aref (symbol-name arg) 0))
+ (not (eq arg '&optional))
+ (not (eq arg '&rest)))
+ (byte-compile-warn "unrecognized `&' keyword in arglist: %s"
+ arg))))
(cond (int
;; Skip (interactive) if it is in front (the most usual location).
(if (eq int (car body))
(if (if (eq (car (car rest)) 'byte-constant)
(or (consp tmp)
(and (symbolp tmp)
- (not (keywordp tmp))
- (not (memq tmp '(nil t))))))
+ (not (byte-compile-constant-symbol-p tmp)))))
(if maycall
(setq body (cons (list 'quote tmp) body)))
(setq body (cons tmp body))))
;; This is the recursive entry point for compiling each subform of an
;; expression.
;; If for-effect is non-nil, byte-compile-form will output a byte-discard
-;; before terminating (ie no value will be left on the stack).
+;; before terminating (ie. no value will be left on the stack).
;; A byte-compile handler may, when for-effect is non-nil, choose output code
;; which does not leave a value on the stack, and then set for-effect to nil
;; (to prevent byte-compile-form from outputting the byte-discard).
(defun byte-compile-form (form &optional for-effect)
(setq form (macroexpand form byte-compile-macro-environment))
(cond ((not (consp form))
- ;; XEmacs addition: keywordp
- (cond ((or (not (symbolp form)) (keywordp form) (memq form '(nil t)))
+ (cond ((or (not (symbolp form))
+ (byte-compile-constant-symbol-p form))
(byte-compile-constant form))
((and for-effect byte-compile-delete-errors)
(setq for-effect nil))
(byte-compile-form form for-effect)
(setq for-effect nil))
((byte-compile-normal-call form)))
- (if for-effect
- (byte-compile-discard)))
+ (when for-effect
+ (byte-compile-discard)))
(defun byte-compile-normal-call (form)
(if byte-compile-generate-call-tree
(or (fboundp 'globally-boundp) (fset 'globally-boundp 'boundp))
(defun byte-compile-variable-ref (base-op var &optional varbind-flags)
- (if (or (not (symbolp var)) (keywordp var) (memq var '(nil t)))
- (byte-compile-warn (if (eq base-op 'byte-varbind)
- "Attempt to let-bind %s %s"
- "Variable reference to %s %s")
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var))
+ (if (or (not (symbolp var)) (byte-compile-constant-symbol-p var))
+ (byte-compile-warn
+ (case base-op
+ (byte-varref "Variable reference to %s %s")
+ (byte-varset "Attempt to set %s %s")
+ (byte-varbind "Attempt to let-bind %s %s"))
+ (if (symbolp var) "constant symbol" "non-symbol")
+ var)
(if (and (get var 'byte-obsolete-variable)
(memq 'obsolete byte-compile-warnings))
(let ((ob (get var 'byte-obsolete-variable)))
(byte-compile-out base-op tmp)))
(defmacro byte-compile-get-constant (const)
- (` (or (if (stringp (, const))
- (assoc (, const) byte-compile-constants)
- (assq (, const) byte-compile-constants))
- (car (setq byte-compile-constants
- (cons (list (, const)) byte-compile-constants))))))
+ `(or (if (stringp ,const)
+ (assoc ,const byte-compile-constants)
+ (assq ,const byte-compile-constants))
+ (car (setq byte-compile-constants
+ (cons (list ,const) byte-compile-constants)))))
;; Use this when the value of a form is a constant. This obeys for-effect.
(defun byte-compile-constant (const)
(byte-defop-compiler20 old-memq 2)
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
-(byte-defop-compiler (= byte-eqlsign) byte-compile-one-or-more-args)
-(byte-defop-compiler (< byte-lss) byte-compile-one-or-more-args)
-(byte-defop-compiler (> byte-gtr) byte-compile-one-or-more-args)
-(byte-defop-compiler (<= byte-leq) byte-compile-one-or-more-args)
-(byte-defop-compiler (>= byte-geq) byte-compile-one-or-more-args)
-(byte-defop-compiler /= byte-compile-/=)
(byte-defop-compiler get 2+1)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 2-3)
(byte-defop-compiler (rplacd byte-setcdr) 2)
(byte-defop-compiler setcar 2)
(byte-defop-compiler setcdr 2)
-;; buffer-substring now has its own function. This used to be
-;; 2+1, but now all args are optional.
-(byte-defop-compiler buffer-substring)
(byte-defop-compiler delete-region 2+1)
(byte-defop-compiler narrow-to-region 2+1)
(byte-defop-compiler (% byte-rem) 2)
\f
(defun byte-compile-subr-wrong-args (form n)
- (byte-compile-warn "%s called with %d arg%s, but requires %s"
- (car form) (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s") n)
+ (when (memq 'subr-callargs byte-compile-warnings)
+ (byte-compile-warn "%s called with %d arg%s, but requires %s"
+ (car form) (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s") n))
;; get run-time wrong-number-of-args error.
(byte-compile-normal-call form))
(defun byte-compile-no-args (form)
- (if (not (= (length form) 1))
- (byte-compile-subr-wrong-args form "none")
- (byte-compile-out (get (car form) 'byte-opcode) 0)))
+ (case (length (cdr form))
+ (0 (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (t (byte-compile-subr-wrong-args form "none"))))
(defun byte-compile-one-arg (form)
- (if (not (= (length form) 2))
- (byte-compile-subr-wrong-args form 1)
- (byte-compile-form (car (cdr form))) ;; Push the argument
- (byte-compile-out (get (car form) 'byte-opcode) 0)))
+ (case (length (cdr form))
+ (1 (byte-compile-form (car (cdr form))) ;; Push the argument
+ (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (t (byte-compile-subr-wrong-args form 1))))
(defun byte-compile-two-args (form)
- (if (not (= (length form) 3))
- (byte-compile-subr-wrong-args form 2)
- (byte-compile-form (car (cdr form))) ;; Push the arguments
- (byte-compile-form (nth 2 form))
- (byte-compile-out (get (car form) 'byte-opcode) 0)))
+ (case (length (cdr form))
+ (2 (byte-compile-form (nth 1 form)) ;; Push the arguments
+ (byte-compile-form (nth 2 form))
+ (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (t (byte-compile-subr-wrong-args form 2))))
(defun byte-compile-three-args (form)
- (if (not (= (length form) 4))
- (byte-compile-subr-wrong-args form 3)
- (byte-compile-form (car (cdr form))) ;; Push the arguments
- (byte-compile-form (nth 2 form))
- (byte-compile-form (nth 3 form))
- (byte-compile-out (get (car form) 'byte-opcode) 0)))
+ (case (length (cdr form))
+ (3 (byte-compile-form (nth 1 form)) ;; Push the arguments
+ (byte-compile-form (nth 2 form))
+ (byte-compile-form (nth 3 form))
+ (byte-compile-out (get (car form) 'byte-opcode) 0))
+ (t (byte-compile-subr-wrong-args form 3))))
(defun byte-compile-zero-or-one-arg (form)
- (let ((len (length form)))
- (cond ((= len 1) (byte-compile-one-arg (append form '(nil))))
- ((= len 2) (byte-compile-one-arg form))
- (t (byte-compile-subr-wrong-args form "0-1")))))
+ (case (length (cdr form))
+ (0 (byte-compile-one-arg (append form '(nil))))
+ (1 (byte-compile-one-arg form))
+ (t (byte-compile-subr-wrong-args form "0-1"))))
(defun byte-compile-one-or-two-args (form)
- (let ((len (length form)))
- (cond ((= len 2) (byte-compile-two-args (append form '(nil))))
- ((= len 3) (byte-compile-two-args form))
- (t (byte-compile-subr-wrong-args form "1-2")))))
+ (case (length (cdr form))
+ (1 (byte-compile-two-args (append form '(nil))))
+ (2 (byte-compile-two-args form))
+ (t (byte-compile-subr-wrong-args form "1-2"))))
(defun byte-compile-two-or-three-args (form)
- (let ((len (length form)))
- (cond ((= len 3) (byte-compile-three-args (append form '(nil))))
- ((= len 4) (byte-compile-three-args form))
- (t (byte-compile-subr-wrong-args form "2-3")))))
+ (case (length (cdr form))
+ (2 (byte-compile-three-args (append form '(nil))))
+ (3 (byte-compile-three-args form))
+ (t (byte-compile-subr-wrong-args form "2-3"))))
;; from Ben Wing <ben@xemacs.org>: some inlined functions have extra
;; optional args added to them in XEmacs 19.12. Changing the byte
;; `byte-compile-subr-wrong-args' also converts the call to non-inlined.
(defun byte-compile-no-args-with-one-extra (form)
- (let ((len (length form)))
- (cond ((= len 1) (byte-compile-no-args form))
- ((= len 2) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "0-1")))))
+ (case (length (cdr form))
+ (0 (byte-compile-no-args form))
+ (1 (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "0-1"))))
(defun byte-compile-one-arg-with-one-extra (form)
- (let ((len (length form)))
- (cond ((= len 2) (byte-compile-one-arg form))
- ((= len 3) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "1-2")))))
+ (case (length (cdr form))
+ (1 (byte-compile-one-arg form))
+ (2 (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "1-2"))))
(defun byte-compile-two-args-with-one-extra (form)
- (let ((len (length form)))
- (cond ((= len 3) (byte-compile-two-args form))
- ((= len 4) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "2-3")))))
+ (case (length (cdr form))
+ (2 (byte-compile-two-args form))
+ (3 (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "2-3"))))
(defun byte-compile-zero-or-one-arg-with-one-extra (form)
- (let ((len (length form)))
- (cond ((= len 1) (byte-compile-one-arg (append form '(nil))))
- ((= len 2) (byte-compile-one-arg form))
- ((= len 3) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "0-2")))))
+ (case (length (cdr form))
+ (0 (byte-compile-one-arg (append form '(nil))))
+ (1 (byte-compile-one-arg form))
+ (2 (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "0-2"))))
(defun byte-compile-one-or-two-args-with-one-extra (form)
- (let ((len (length form)))
- (cond ((= len 2) (byte-compile-two-args (append form '(nil))))
- ((= len 3) (byte-compile-two-args form))
- ((= len 4) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "1-3")))))
+ (case (length (cdr form))
+ (1 (byte-compile-two-args (append form '(nil))))
+ (2 (byte-compile-two-args form))
+ (3 (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "1-3"))))
(defun byte-compile-two-or-three-args-with-one-extra (form)
- (let ((len (length form)))
- (cond ((= len 3) (byte-compile-three-args (append form '(nil))))
- ((= len 4) (byte-compile-three-args form))
- ((= len 5) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "2-4")))))
+ (case (length (cdr form))
+ (2 (byte-compile-three-args (append form '(nil))))
+ (3 (byte-compile-three-args form))
+ (4 (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "2-4"))))
(defun byte-compile-no-args-with-two-extra (form)
- (let ((len (length form)))
- (cond ((= len 1) (byte-compile-no-args form))
- ((or (= len 2) (= len 3)) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "0-2")))))
+ (case (length (cdr form))
+ (0 (byte-compile-no-args form))
+ ((1 2) (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "0-2"))))
(defun byte-compile-one-arg-with-two-extra (form)
- (let ((len (length form)))
- (cond ((= len 2) (byte-compile-one-arg form))
- ((or (= len 3) (= len 4)) (byte-compile-normal-call form))
- (t (byte-compile-subr-wrong-args form "1-3")))))
+ (case (length (cdr form))
+ (1 (byte-compile-one-arg form))
+ ((2 3) (byte-compile-normal-call form))
+ (t (byte-compile-subr-wrong-args form "1-3"))))
;; XEmacs: used for functions that have a different opcode in v19 than v20.
;; this includes `eq', `equal', and other old-ified functions.
(defun byte-compile-discard ()
(byte-compile-out 'byte-discard 0))
+;; Compile a function that accepts one or more args and is right-associative.
+;; We do it by left-associativity so that the operations
+;; are done in the same order as in interpreted code.
+;(defun byte-compile-associative (form)
+; (if (cdr form)
+; (let ((opcode (get (car form) 'byte-opcode))
+; (args (copy-sequence (cdr form))))
+; (byte-compile-form (car args))
+; (setq args (cdr args))
+; (while args
+; (byte-compile-form (car args))
+; (byte-compile-out opcode 0)
+; (setq args (cdr args))))
+; (byte-compile-constant (eval form))))
;; Compile a function that accepts one or more args and is right-associative.
;; We do it by left-associativity so that the operations
;; are done in the same order as in interpreted code.
(defun byte-compile-associative (form)
- (if (cdr form)
- (let ((opcode (get (car form) 'byte-opcode))
- (args (copy-sequence (cdr form))))
- (byte-compile-form (car args))
- (setq args (cdr args))
- (while args
- (byte-compile-form (car args))
- (byte-compile-out opcode 0)
- (setq args (cdr args))))
- (byte-compile-constant (eval form))))
+ (let ((args (cdr form))
+ (opcode (get (car form) 'byte-opcode)))
+ (case (length args)
+ (0 (byte-compile-constant (eval form)))
+ (t (byte-compile-form (car args))
+ (dolist (arg (cdr args))
+ (byte-compile-form arg)
+ (byte-compile-out opcode 0))))))
\f
;; more complicated compiler macros
(byte-defop-compiler nconc)
(byte-defop-compiler-1 beginning-of-line)
-(defun byte-compile-one-or-more-args (form)
- (let ((len (length form)))
- (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more"))
- ((= len 2) (byte-compile-constant t))
- ((= len 3) (byte-compile-two-args form))
- (t (byte-compile-normal-call form)))))
+(byte-defop-compiler (= byte-eqlsign) byte-compile-arithcompare)
+(byte-defop-compiler (< byte-lss) byte-compile-arithcompare)
+(byte-defop-compiler (> byte-gtr) byte-compile-arithcompare)
+(byte-defop-compiler (<= byte-leq) byte-compile-arithcompare)
+(byte-defop-compiler (>= byte-geq) byte-compile-arithcompare)
+
+(defun byte-compile-arithcompare (form)
+ (case (length (cdr form))
+ (0 (byte-compile-subr-wrong-args form "1 or more"))
+ (1 (byte-compile-constant t))
+ (2 (byte-compile-two-args form))
+ (t (byte-compile-normal-call form))))
+
+(byte-defop-compiler /= byte-compile-/=)
(defun byte-compile-/= (form)
- (let ((len (length form)))
- (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more"))
- ((= len 2) (byte-compile-constant t))
- ;; optimize (/= X Y) to (not (= X Y))
- ((= len 3) (byte-compile-form-do-effect `(not (= ,@(cdr form)))))
- (t (byte-compile-normal-call form)))))
+ (case (length (cdr form))
+ (0 (byte-compile-subr-wrong-args form "1 or more"))
+ (1 (byte-compile-constant t))
+ ;; optimize (/= X Y) to (not (= X Y))
+ (2 (byte-compile-form-do-effect `(not (= ,@(cdr form)))))
+ (t (byte-compile-normal-call form))))
+
+;; buffer-substring now has its own function. This used to be
+;; 2+1, but now all args are optional.
+(byte-defop-compiler buffer-substring)
(defun byte-compile-buffer-substring (form)
;; buffer-substring used to take exactly two args, but now takes 0-3.
(t (byte-compile-subr-wrong-args form "0-3"))))
(defun byte-compile-list (form)
- (let ((count (length (cdr form))))
- (cond ((= count 0)
- (byte-compile-constant nil))
- ((< count 5)
- (mapcar 'byte-compile-form (cdr form))
- (byte-compile-out
- (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
- ((< count 256)
- (mapcar 'byte-compile-form (cdr form))
- (byte-compile-out 'byte-listN count))
- (t (byte-compile-normal-call form)))))
+ (let* ((args (cdr form))
+ (nargs (length args)))
+ (cond
+ ((= nargs 0)
+ (byte-compile-constant nil))
+ ((< nargs 5)
+ (mapcar 'byte-compile-form args)
+ (byte-compile-out
+ (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs))
+ 0))
+ ((< nargs 256)
+ (mapcar 'byte-compile-form args)
+ (byte-compile-out 'byte-listN nargs))
+ (t (byte-compile-normal-call form)))))
(defun byte-compile-concat (form)
- (let ((count (length (cdr form))))
- (cond ((and (< 1 count) (< count 5))
- (mapcar 'byte-compile-form (cdr form))
- (byte-compile-out
- (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
- 0))
- ;; Concat of one arg is not a no-op if arg is not a string.
- ((= count 0)
- (byte-compile-form ""))
- ((< count 256)
- (mapcar 'byte-compile-form (cdr form))
- (byte-compile-out 'byte-concatN count))
- ((byte-compile-normal-call form)))))
+ (let* ((args (cdr form))
+ (nargs (length args)))
+ ;; Concat of one arg is not a no-op if arg is not a string.
+ (cond
+ ((memq nargs '(2 3 4))
+ (mapcar 'byte-compile-form args)
+ (byte-compile-out
+ (aref [byte-concat2 byte-concat3 byte-concat4] (- nargs 2))
+ 0))
+ ((eq nargs 0)
+ (byte-compile-form ""))
+ ((< nargs 256)
+ (mapcar 'byte-compile-form args)
+ (byte-compile-out 'byte-concatN nargs))
+ ((byte-compile-normal-call form)))))
(defun byte-compile-minus (form)
- (if (null (setq form (cdr form)))
- (byte-compile-constant 0)
- (byte-compile-form (car form))
- (if (cdr form)
- (while (setq form (cdr form))
- (byte-compile-form (car form))
- (byte-compile-out 'byte-diff 0))
- (byte-compile-out 'byte-negate 0))))
+ (let ((args (cdr form)))
+ (case (length args)
+ (0 (byte-compile-subr-wrong-args form "1 or more"))
+ (1 (byte-compile-form (car args))
+ (byte-compile-out 'byte-negate 0))
+ (t (byte-compile-form (car args))
+ (dolist (elt (cdr args))
+ (byte-compile-form elt)
+ (byte-compile-out 'byte-diff 0))))))
(defun byte-compile-quo (form)
- (let ((len (length form)))
- (cond ((<= len 2)
- (byte-compile-subr-wrong-args form "2 or more"))
- (t
- (byte-compile-form (car (setq form (cdr form))))
- (while (setq form (cdr form))
- (byte-compile-form (car form))
- (byte-compile-out 'byte-quo 0))))))
+ (let ((args (cdr form)))
+ (case (length args)
+ (0 (byte-compile-subr-wrong-args form "1 or more"))
+ (1 (byte-compile-constant 1)
+ (byte-compile-form (car args))
+ (byte-compile-out 'byte-quo 0))
+ (t (byte-compile-form (car args))
+ (dolist (elt (cdr args))
+ (byte-compile-form elt)
+ (byte-compile-out 'byte-quo 0))))))
(defun byte-compile-nconc (form)
- (let ((len (length form)))
- (cond ((= len 1)
- (byte-compile-constant nil))
- ((= len 2)
- ;; nconc of one arg is a noop, even if that arg isn't a list.
- (byte-compile-form (nth 1 form)))
- (t
- (byte-compile-form (car (setq form (cdr form))))
- (while (setq form (cdr form))
- (byte-compile-form (car form))
- (byte-compile-out 'byte-nconc 0))))))
+ (let ((args (cdr form)))
+ (case (length args)
+ (0 (byte-compile-constant nil))
+ ;; nconc of one arg is a noop, even if that arg isn't a list.
+ (1 (byte-compile-form (car args)))
+ (t (byte-compile-form (car args))
+ (dolist (elt (cdr args))
+ (byte-compile-form elt)
+ (byte-compile-out 'byte-nconc 0))))))
(defun byte-compile-fset (form)
;; warn about forms like (fset 'foo '(lambda () ...))
;; I'm sick of getting mail asking me whether that warning is a problem.
(let ((fn (nth 2 form))
body)
- (if (and (eq (car-safe fn) 'quote)
- (eq (car-safe (setq fn (nth 1 fn))) 'lambda)
- (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code)))
- (progn
- (setq body (cdr (cdr fn)))
- (if (stringp (car body)) (setq body (cdr body)))
- (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
- (if (and (consp (car body))
- (not (eq 'byte-code (car (car body)))))
- (byte-compile-warn
- "A quoted lambda form is the second argument of fset. This is probably
+ (when (and (eq (car-safe fn) 'quote)
+ (eq (car-safe (setq fn (nth 1 fn))) 'lambda)
+ (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code)))
+ (setq body (cdr (cdr fn)))
+ (if (stringp (car body)) (setq body (cdr body)))
+ (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
+ (if (and (consp (car body))
+ (not (eq 'byte-code (car (car body)))))
+ (byte-compile-warn
+ "A quoted lambda form is the second argument of fset. This is probably
not what you want, as that lambda cannot be compiled. Consider using
- the syntax (function (lambda (...) ...)) instead.")))))
+ the syntax (function (lambda (...) ...)) instead."))))
(byte-compile-two-args form))
(defun byte-compile-funarg (form)
(while (setq form (cdr form))
(byte-compile-form (car form))
(byte-compile-out 'byte-insert 0)
- (if (cdr form)
- (byte-compile-discard))))))
+ (when (cdr form)
+ (byte-compile-discard))))))
;; alas, the old (pre-19.12, and all existing versions of FSFmacs 19)
;; byte compiler will generate incorrect code for
(byte-defop-compiler-1 quote-form)
(defun byte-compile-setq (form)
- (let ((args (cdr form)))
- (if args
- (while args
- (byte-compile-form (car (cdr args)))
- (or for-effect (cdr (cdr args))
+ (let ((args (cdr form)) var val)
+ (if (null args)
+ ;; (setq), with no arguments.
+ (byte-compile-form nil for-effect)
+ (while args
+ (setq var (pop args))
+ (if (null args)
+ ;; Odd number of args? Let `set' get the error.
+ (byte-compile-form `(set ',var) for-effect)
+ (setq val (pop args))
+ (if (keywordp var)
+ ;; (setq :foo ':foo) compatibility kludge
+ (byte-compile-form `(set ',var ,val) (if args t for-effect))
+ (byte-compile-form val)
+ (unless (or args for-effect)
(byte-compile-out 'byte-dup 0))
- (byte-compile-variable-ref 'byte-varset (car args))
- (setq args (cdr (cdr args))))
- ;; (setq), with no arguments.
- (byte-compile-form nil for-effect))
- (setq for-effect nil)))
+ (byte-compile-variable-ref 'byte-varset var))))))
+ (setq for-effect nil))
(defun byte-compile-set (form)
;; Compile (set 'foo x) as (setq foo x) for trivially better code and so
;; that we get applicable warnings. Compile everything else (including
;; malformed calls) like a normal 2-arg byte-coded function.
- (if (or (not (eq (car-safe (nth 1 form)) 'quote))
- (not (= (length form) 3))
- (not (= (length (nth 1 form)) 2)))
- (byte-compile-two-args form)
- (byte-compile-setq (list 'setq (nth 1 (nth 1 form)) (nth 2 form)))))
+ (let ((symform (nth 1 form))
+ (valform (nth 2 form))
+ sym)
+ (if (and (= (length form) 3)
+ (= (safe-length symform) 2)
+ (eq (car symform) 'quote)
+ (symbolp (setq sym (car (cdr symform))))
+ (not (byte-compile-constant-symbol-p sym)))
+ (byte-compile-setq `(setq ,sym ,valform))
+ (byte-compile-two-args form))))
(defun byte-compile-setq-default (form)
- (let ((rest (cdr form)))
- ;; emit multiple calls to set-default if necessary
- (while rest
- (byte-compile-form
- (list 'set-default (list 'quote (car rest)) (car (cdr rest)))
- (not (null (cdr (cdr rest)))))
- (setq rest (cdr (cdr rest))))))
+ (let ((args (cdr form)))
+ (if (null args)
+ ;; (setq-default), with no arguments.
+ (byte-compile-form nil for-effect)
+ ;; emit multiple calls to `set-default' if necessary
+ (while args
+ (byte-compile-form
+ ;; Odd number of args? Let `set-default' get the error.
+ `(set-default ',(pop args) ,@(if args (list (pop args)) nil))
+ (if args t for-effect)))))
+ (setq for-effect nil))
+
(defun byte-compile-set-default (form)
- (let ((rest (cdr form)))
- (if (cdr (cdr (cdr form)))
- ;; emit multiple calls to set-default if necessary; all but last
- ;; for-effect (this recurses.)
- (while rest
- (byte-compile-form
- (list 'set-default (car rest) (car (cdr rest)))
- (not (null (cdr rest))))
- (setq rest (cdr (cdr rest))))
- ;; else, this is the one-armed version
- (let ((var (nth 1 form))
- ;;(val (nth 2 form))
- )
- ;; notice calls to set-default/setq-default for variables which
- ;; have not been declared with defvar/defconst.
- (if (and (memq 'free-vars byte-compile-warnings)
- (or (null var)
- (and (eq (car-safe var) 'quote)
- (= 2 (length var)))))
- (let ((sym (nth 1 var))
- cell)
- (or (and sym (symbolp sym) (globally-boundp sym))
- (and (setq cell (assq sym byte-compile-bound-variables))
- (setcdr cell (logior (cdr cell)
- byte-compile-assigned-bit)))
- (memq sym byte-compile-free-assignments)
- (if (or (not (symbolp sym)) (memq sym '(t nil)))
- (progn
- (byte-compile-warn
- "Attempt to set-globally %s %s"
- (if (symbolp sym) "constant" "nonvariable")
- (prin1-to-string sym)))
- (progn
- (byte-compile-warn "assignment to free variable %s" sym)
- (setq byte-compile-free-assignments
- (cons sym byte-compile-free-assignments)))))))
- ;; now emit a normal call to set-default (or possibly multiple calls)
- (byte-compile-normal-call form)))))
+ (let* ((args (cdr form))
+ (nargs (length args))
+ (var (car args)))
+ (when (and (= (safe-length var) 2)
+ (eq (car var) 'quote))
+ (let ((sym (nth 1 var)))
+ (cond
+ ((not (symbolp sym))
+ (byte-compile-warn "Attempt to set-globally non-symbol %s" sym))
+ ((byte-compile-constant-symbol-p sym)
+ (byte-compile-warn "Attempt to set-globally constant symbol %s" sym))
+ ((let ((cell (assq sym byte-compile-bound-variables)))
+ (and cell
+ (setcdr cell (logior (cdr cell) byte-compile-assigned-bit))
+ t)))
+ ;; notice calls to set-default/setq-default for variables which
+ ;; have not been declared with defvar/defconst.
+ ((globally-boundp sym)) ; OK
+ ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed?
+ ((memq sym byte-compile-free-assignments)) ; already warned about sym
+ (t
+ (byte-compile-warn "assignment to free variable %s" sym)
+ (push sym byte-compile-free-assignments)))))
+ (if (= nargs 2)
+ ;; now emit a normal call to set-default
+ (byte-compile-normal-call form)
+ (byte-compile-subr-wrong-args form 2))))
(defun byte-compile-quote (form)
(byte-compile-body-do-effect (cdr form)))
(defun byte-compile-prog1 (form)
- (byte-compile-form-do-effect (car (cdr form)))
- (byte-compile-body (cdr (cdr form)) t))
+ (setq form (cdr form))
+ (byte-compile-form-do-effect (pop form))
+ (byte-compile-body form t))
(defun byte-compile-prog2 (form)
- (byte-compile-form (nth 1 form) t)
- (byte-compile-form-do-effect (nth 2 form))
- (byte-compile-body (cdr (cdr (cdr form))) t))
+ (setq form (cdr form))
+ (byte-compile-form (pop form) t)
+ (byte-compile-form-do-effect (pop form))
+ (byte-compile-body form t))
(defmacro byte-compile-goto-if (cond discard tag)
- (` (byte-compile-goto
- (if (, cond)
- (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
- (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
- (, tag))))
+ `(byte-compile-goto
+ (if ,cond
+ (if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
+ (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
+ ,tag))
(defun byte-compile-if (form)
(byte-compile-form (car (cdr form)))
(defun byte-compile-out-tag (tag)
- (setq byte-compile-output (cons tag byte-compile-output))
+ (push tag byte-compile-output)
(if (cdr (cdr tag))
(progn
;; ## remove this someday
(setcdr (cdr tag) byte-compile-depth)))
(defun byte-compile-goto (opcode tag)
- (setq byte-compile-output (cons (cons opcode tag) byte-compile-output))
+ (push (cons opcode tag) byte-compile-output)
(setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
(1- byte-compile-depth)
byte-compile-depth))
(1- byte-compile-depth))))
(defun byte-compile-out (opcode offset)
- (setq byte-compile-output (cons (cons opcode offset) byte-compile-output))
- (cond ((eq opcode 'byte-call)
- (setq byte-compile-depth (- byte-compile-depth offset)))
- ((eq opcode 'byte-return)
- ;; This is actually an unnecessary case, because there should be
- ;; no more opcodes behind byte-return.
- (setq byte-compile-depth nil))
- (t
- (setq byte-compile-depth (+ byte-compile-depth
- (or (aref byte-stack+-info
- (symbol-value opcode))
- (- (1- offset))))
- byte-compile-maxdepth (max byte-compile-depth
- byte-compile-maxdepth))))
+ (push (cons opcode offset) byte-compile-output)
+ (case opcode
+ (byte-call
+ (setq byte-compile-depth (- byte-compile-depth offset)))
+ (byte-return
+ ;; This is actually an unnecessary case, because there should be
+ ;; no more opcodes behind byte-return.
+ (setq byte-compile-depth nil))
+ (t
+ (setq byte-compile-depth (+ byte-compile-depth
+ (or (aref byte-stack+-info
+ (symbol-value opcode))
+ (- (1- offset))))
+ byte-compile-maxdepth (max byte-compile-depth
+ byte-compile-maxdepth))))
;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
)
(or (memq byte-compile-current-form (nth 1 entry)) ;callers
(setcar (cdr entry)
(cons byte-compile-current-form (nth 1 entry))))
- (setq byte-compile-call-tree
- (cons (list (car form) (list byte-compile-current-form) nil)
- byte-compile-call-tree)))
+ (push (list (car form) (list byte-compile-current-form) nil)
+ byte-compile-call-tree))
;; annotate the current function
(if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
(or (memq (car form) (nth 2 entry)) ;called
(setcar (cdr (cdr entry))
(cons (car form) (nth 2 entry))))
- (setq byte-compile-call-tree
- (cons (list byte-compile-current-form nil (list (car form)))
- byte-compile-call-tree)))
- ))
+ (push (list byte-compile-current-form nil (list (car form)))
+ byte-compile-call-tree))))
;; Renamed from byte-compile-report-call-tree
;; to avoid interfering with completion of byte-compile-file.
(sort byte-compile-call-tree
(cond
((eq byte-compile-call-tree-sort 'callers)
- (function (lambda (x y) (< (length (nth 1 x))
- (length (nth 1 y))))))
+ #'(lambda (x y) (< (length (nth 1 x))
+ (length (nth 1 y)))))
((eq byte-compile-call-tree-sort 'calls)
- (function (lambda (x y) (< (length (nth 2 x))
- (length (nth 2 y))))))
+ #'(lambda (x y) (< (length (nth 2 x))
+ (length (nth 2 y)))))
((eq byte-compile-call-tree-sort 'calls+callers)
- (function (lambda (x y) (< (+ (length (nth 1 x))
- (length (nth 2 x)))
- (+ (length (nth 1 y))
- (length (nth 2 y)))))))
+ #'(lambda (x y) (< (+ (length (nth 1 x))
+ (length (nth 2 x)))
+ (+ (length (nth 1 y))
+ (length (nth 2 y))))))
((eq byte-compile-call-tree-sort 'name)
- (function (lambda (x y) (string< (car x)
- (car y)))))
+ #'(lambda (x y) (string< (car x)
+ (car y))))
(t (error
"`byte-compile-call-tree-sort': `%s' - unknown sort mode"
byte-compile-call-tree-sort))))))
(defvar command-line-args-left) ;Avoid 'free variable' warning
(if (not noninteractive)
(error "`batch-byte-compile' is to be used only with -batch"))
- (let ((error nil)
- (debug-issue-ebola-notices 0)) ; Hack -slb
+ (let ((error nil))
(while command-line-args-left
(if (file-directory-p (expand-file-name (car command-line-args-left)))
(let ((files (directory-files (car command-line-args-left)))
(if (fboundp 'display-error) ; XEmacs 19.8+
(display-error err nil)
(princ (or (get (car err) 'error-message) (car err)))
- (mapcar '(lambda (x) (princ " ") (prin1 x)) (cdr err)))
+ (mapcar #'(lambda (x) (princ " ") (prin1 x)) (cdr err)))
(princ "\n")
nil)))
(error "batch-byte-recompile-directory is to be used only with -batch"))
(or command-line-args-left
(setq command-line-args-left '(".")))
- (let ((byte-recompile-directory-ignore-errors-p t)
- (debug-issue-ebola-notices 0))
+ (let ((byte-recompile-directory-ignore-errors-p t))
(while command-line-args-left
(byte-recompile-directory (car command-line-args-left))
(setq command-line-args-left (cdr command-line-args-left))))
(assq 'byte-code (symbol-function 'byte-compile-form))
(let ((byte-optimize nil) ; do it fast
(byte-compile-warnings nil))
- (mapcar '(lambda (x)
- (or noninteractive (message "compiling %s..." x))
- (byte-compile x)
- (or noninteractive (message "compiling %s...done" x)))
+ (mapcar #'(lambda (x)
+ (or noninteractive (message "compiling %s..." x))
+ (byte-compile x)
+ (or noninteractive (message "compiling %s...done" x)))
'(byte-compile-normal-call
byte-compile-form
byte-compile-body
"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
(regexp :tag "To")))
:group 'find-file)
-;;; Turn off backup files on VMS since it has version numbers.
-(defcustom make-backup-files (not (eq system-type 'vax-vms))
+(defcustom make-backup-files t
"*Non-nil means make a backup of a file the first time it is saved.
This can be done by renaming the file or by copying.
"Change current directory to given absolute file name DIR."
;; Put the name into directory syntax now,
;; because otherwise expand-file-name may give some bad results.
- (if (not (eq system-type 'vax-vms))
- (setq dir (file-name-as-directory dir)))
+ (setq dir (file-name-as-directory dir))
;; XEmacs change: stig@hackvan.com
(if find-file-use-truenames
(setq dir (file-truename dir)))
;; If the home dir is just /, don't change it.
(not (and (= (match-end 0) 1) ;#### unix-specific
(= (aref filename 0) ?/)))
- (not (and (or (eq system-type 'ms-dos)
- (eq system-type 'windows-nt))
+ (not (and (memq system-type '(ms-dos windows-nt))
(save-match-data
(string-match "^[a-zA-Z]:/$" filename)))))
(setq filename
filename)))
(defcustom find-file-not-true-dirname-list nil
- "*List of logical names for which visiting shouldn't save the true dirname.
-On VMS, when you visit a file using a logical name that searches a path,
-you may or may not want the visited file name to record the specific
-directory where the file was found. If you *do not* want that, add the logical
-name to this list as a string."
+ "*List of logical names for which visiting shouldn't save the true dirname."
:type '(repeat (string :tag "Name"))
:group 'find-file)
(unless buffer-file-truename
(setq buffer-file-truename truename))
(setq buffer-file-number number)
- ;; On VMS, we may want to remember which directory in
- ;; a search list the file was found in.
- (and (eq system-type 'vax-vms)
- (let (logical)
- (if (string-match ":" (file-name-directory filename))
- (setq logical (substring (file-name-directory filename)
- 0 (match-beginning 0))))
- (not (member logical find-file-not-true-dirname-list)))
- (setq buffer-file-name buffer-file-truename))
(and find-file-use-truenames
;; This should be in C. Put pathname
;; abbreviations that have been explicitly
'(("\\.te?xt\\'" . text-mode)
("\\.[ch]\\'" . c-mode)
("\\.el\\'" . emacs-lisp-mode)
- ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode)
+ ("\\.\\(?:[CH]\\|cc\\|hh\\)\\'" . c++-mode)
("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode)
("\\.java\\'" . java-mode)
("\\.idl\\'" . idl-mode)
- ("\\.f\\(or\\)?\\'" . fortran-mode)
- ("\\.F\\(OR\\)?\\'" . fortran-mode)
+ ("\\.f\\(?:or\\)?\\'" . fortran-mode)
+ ("\\.F\\(?:OR\\)?\\'" . fortran-mode)
("\\.[fF]90\\'" . f90-mode)
;;; Less common extensions come here
;;; so more common ones above are found faster.
("\\.\\([pP][Llm]\\|al\\)\\'" . perl-mode)
("\\.py\\'" . python-mode)
- ("\\.texi\\(nfo\\)?\\'" . texinfo-mode)
+ ("\\.texi\\(?:nfo\\)?\\'" . texinfo-mode)
("\\.ad[abs]\\'" . ada-mode)
- ("\\.c?l\\(i?sp\\)?\\'" . lisp-mode)
- ("\\.p\\(as\\)?\\'" . pascal-mode)
+ ("\\.c?l\\(?:i?sp\\)?\\'" . lisp-mode)
+ ("\\.p\\(?:as\\)?\\'" . pascal-mode)
("\\.ltx\\'" . latex-mode)
("\\.[sS]\\'" . asm-mode)
- ("[Cc]hange.?[Ll]og?\\(.[0-9]+\\)?\\'" . change-log-mode)
+ ("[Cc]hange.?[Ll]og?\\(?:.[0-9]+\\)?\\'" . change-log-mode)
("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode)
("\\.scm?\\(?:\\.[0-9]*\\)?\\'" . scheme-mode)
("\\.e\\'" . eiffel-mode)
("\\.mss\\'" . scribe-mode)
- ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode)
+ ("\\.m\\(?:[mes]\\|an\\)\\'" . nroff-mode)
("\\.icn\\'" . icon-mode)
- ("\\.\\([ckz]?sh\\|shar\\)\\'" . sh-mode)
+ ("\\.\\(?:[ckz]?sh\\|shar\\)\\'" . sh-mode)
;; #### Unix-specific!
- ("/\\.\\(bash_\\|z\\)?\\(profile\\|login\||logout\\)\\'" . sh-mode)
- ("/\\.\\([ckz]sh\\|bash\\|tcsh\\|es\\|xinit\\|startx\\)rc\\'" . sh-mode)
- ("/\\.\\([kz]shenv\\|xsession\\)\\'" . sh-mode)
+ ("/\\.\\(?:bash_\\|z\\)?\\(profile\\|login\||logout\\)\\'" . sh-mode)
+ ("/\\.\\(?:[ckz]sh\\|bash\\|tcsh\\|es\\|xinit\\|startx\\)rc\\'" . sh-mode)
+ ("/\\.\\(?:[kz]shenv\\|xsession\\)\\'" . sh-mode)
;; The following come after the ChangeLog pattern for the sake of
;; ChangeLog.1, etc. and after the .scm.[0-9] pattern too.
("\\.[12345678]\\'" . nroff-mode)
("\\.[tT]e[xX]\\'" . tex-mode)
- ("\\.\\(sty\\|cls\\|bbl\\)\\'" . latex-mode)
+ ("\\.\\(?:sty\\|cls\\|bbl\\)\\'" . latex-mode)
("\\.bib\\'" . bibtex-mode)
("\\.article\\'" . text-mode)
("\\.letter\\'" . text-mode)
- ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode)
+ ("\\.\\(?:tcl\\|exp\\)\\'" . tcl-mode)
("\\.wrl\\'" . vrml-mode)
("\\.awk\\'" . awk-mode)
("\\.prolog\\'" . prolog-mode)
- ("\\.tar\\'" . tar-mode)
- ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode)
+ ("\\.\\(?:arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode)
;; Mailer puts message to be edited in /tmp/Re.... or Message
;; #### Unix-specific!
("\\`/tmp/Re" . text-mode)
("\\.oak\\'" . scheme-mode)
("\\.s?html?\\'" . html-mode)
("\\.htm?l?3\\'" . html3-mode)
- ("\\.\\(sgml?\\|dtd\\)\\'" . sgml-mode)
+ ("\\.\\(?:sgml?\\|dtd\\)\\'" . sgml-mode)
("\\.c?ps\\'" . postscript-mode)
;; .emacs following a directory delimiter in either Unix or
;; Windows syntax.
("\\.X\\(defaults\\|environment\\|resources\\|modmap\\)\\'" . xrdb-mode)
;; #### The following three are Unix-specific (but do we care?)
("/app-defaults/" . xrdb-mode)
- ("\\.[^/]*wm\\'" . winmgr-mode)
- ("\\.[^/]*wm2?rc" . winmgr-mode)
- ("\\.[Jj][Pp][Ee]?[Gg]\\'" . image-mode)
- ("\\.[Pp][Nn][Gg]\\'" . image-mode)
- ("\\.[Gg][Ii][Ff]\\'" . image-mode)
+ ("\\.[^/]*wm2?\\(?:rc\\)?\\'" . winmgr-mode)
+ ("\\.\\(?:jpe?g\\|JPE?G\\|png\\|PNG\\|gif\\|GIF\\|tiff?\\|TIFF?\\)\\'" . image-mode)
)
"Alist of filename patterns vs. corresponding major mode functions.
Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL).
with the name of the interpreter specified in the first line.
If it matches, mode MODE is selected.")
-(defvar inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'" "\\.tgz\\'"
- "\\.tar\\.gz\\'"))
+(defvar binary-file-regexps
+ (purecopy
+ '("\\.\\(?:bz2\\|elc\\|g\\(if\\|z\\)\\|jp\\(eg\\|g\\)\\|png\\|t\\(ar\\|gz\\|iff\\)\\|[Zo]\\)\\'"))
+ "List of regexps of filenames containing binary (non-text) data.")
+
+; (eval-when-compile
+; (require 'regexp-opt)
+; (list
+; (format "\\.\\(?:%s\\)\\'"
+; (regexp-opt
+; '("tar"
+; "tgz"
+; "gz"
+; "bz2"
+; "Z"
+; "o"
+; "elc"
+; "png"
+; "gif"
+; "tiff"
+; "jpg"
+; "jpeg"))))))
+
+(defvar inhibit-first-line-modes-regexps
+ (purecopy binary-file-regexps)
"List of regexps; if one matches a file name, don't look for `-*-'.")
(defvar inhibit-first-line-modes-suffixes nil
(mode nil))
;; Find first matching alist entry.
(let ((case-fold-search
- (memq system-type '(vax-vms windows-nt))))
+ (memq system-type '(windows-nt))))
(while (and (not mode) alist)
(if (string-match (car (car alist)) name)
(if (and (consp (cdr (car alist)))
(let ((new-name (file-name-nondirectory buffer-file-name)))
(if (string= new-name "")
(error "Empty file name"))
- (if (eq system-type 'vax-vms)
- (setq new-name (downcase new-name)))
(setq default-directory (file-name-directory buffer-file-name))
(or (string= new-name (buffer-name))
(rename-buffer new-name t))))
;; Now delete the old versions, if desired.
(if delete-old-versions
(while targets
- (condition-case ()
- (delete-file (car targets))
- (file-error nil))
+ (ignore-file-errors (delete-file (car targets)))
(setq targets (cdr targets))))
setmodes)
(file-error nil)))))))))
(if handler
(funcall handler 'file-name-sans-versions name keep-backup-version)
(substring name 0
- (if (eq system-type 'vax-vms)
- ;; VMS version number is (a) semicolon, optional
- ;; sign, zero or more digits or (b) period, option
- ;; sign, zero or more digits, provided this is the
- ;; second period encountered outside of the
- ;; device/directory part of the file name.
- (or (string-match ";[-+]?[0-9]*\\'" name)
- (if (string-match "\\.[^]>:]*\\(\\.[-+]?[0-9]*\\)\\'"
- name)
- (match-beginning 1))
- (length name))
- (if keep-backup-version
- (length name)
- (or (string-match "\\.~[0-9.]+~\\'" name)
- ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~"
- (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name)))
- (and pos
- ;; #### - is this filesystem check too paranoid?
- (file-exists-p (substring name 0 pos))
- pos))
- (string-match "~\\'" name)
- (length name))))))))
+ (if keep-backup-version
+ (length name)
+ (or (string-match "\\.~[0-9.]+~\\'" name)
+ ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~"
+ (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name)))
+ (and pos
+ ;; #### - is this filesystem check too paranoid?
+ (file-exists-p (substring name 0 pos))
+ pos))
+ (string-match "~\\'" name)
+ (length name)))))))
(defun file-ownership-preserved-p (file)
"Return t if deleting FILE and rewriting it would preserve the owner."
(string-to-int (substring fn bv-length -1))
0))
-;; I believe there is no need to alter this behavior for VMS;
-;; since backup files are not made on VMS, it should not get called.
(defun find-backup-file-name (fn)
"Find a file name for a backup file, and suggestions for deletions.
Value is a list whose car is the name for the backup file
(expand-file-name (or directory default-directory))))
;; On Microsoft OSes, if FILENAME and DIRECTORY have different
;; drive names, they can't be relative, so return the absolute name.
- (if (and (or (eq system-type 'ms-dos)
- (eq system-type 'windows-nt))
+ (if (and (memq system-type '(ms-dos windows-nt))
(not (string-equal (substring fname 0 2)
(substring directory 0 2))))
filename
(not (string= buffer-file-name buffer-auto-save-file-name))
(or force (recent-auto-save-p))
(progn
- (condition-case ()
- (delete-file buffer-auto-save-file-name)
- (file-error nil))
+ (ignore-file-errors (delete-file buffer-auto-save-file-name))
(set-buffer-auto-saved))))
;; XEmacs change (from Sun)
(set-buffer (buffer-base-buffer)))
(if (buffer-modified-p)
(let ((recent-save (recent-auto-save-p)))
- ;; On VMS, rename file and buffer to get rid of version number.
- (if (and (eq system-type 'vax-vms)
- (not (string= buffer-file-name
- (file-name-sans-versions buffer-file-name))))
- (let (buffer-new-name)
- ;; Strip VMS version number before save.
- (setq buffer-file-name
- (file-name-sans-versions buffer-file-name))
- ;; Construct a (unique) buffer name to correspond.
- (let ((buf (create-file-buffer (downcase buffer-file-name))))
- (setq buffer-new-name (buffer-name buf))
- (kill-buffer buf))
- (rename-buffer buffer-new-name)))
;; If buffer has no file name, ask user for one.
(or buffer-file-name
(let ((filename
(not (file-exists-p file-name)))
(error "Auto-save file %s not current" file-name))
((save-window-excursion
- (if (not (eq system-type 'vax-vms))
- (with-output-to-temp-buffer "*Directory*"
- (buffer-disable-undo standard-output)
- (call-process "ls" nil standard-output nil
- (if (file-symlink-p file) "-lL" "-l")
- file file-name)))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-disable-undo standard-output)
+ (call-process "ls" nil standard-output nil
+ (if (file-symlink-p file) "-lL" "-l")
+ file file-name))
(yes-or-no-p (format "Recover auto save file %s? " file-name)))
(switch-to-buffer (find-file-noselect file t))
(let ((buffer-read-only nil))
;; not its part. Make the regexp say so.
(concat "\\`" result "\\'")))
\f
-(defcustom list-directory-brief-switches
- (if (eq system-type 'vax-vms) "" "-CF")
+(defcustom list-directory-brief-switches "-CF"
"*Switches for list-directory to pass to `ls' for brief listing."
:type 'string
:group 'dired)
-(defcustom list-directory-verbose-switches
- (if (eq system-type 'vax-vms)
- "/PROTECTION/SIZE/DATE/OWNER/WIDTH=(OWNER:10)"
- "-l")
+(defcustom list-directory-verbose-switches "-l"
"*Switches for list-directory to pass to `ls' for verbose listing,"
:type 'string
:group 'dired)
(funcall handler 'insert-directory file switches
wildcard full-directory-p)
(cond
- ((eq system-type 'vax-vms)
- (vms-read-directory file switches (current-buffer)))
((and (fboundp 'mswindows-insert-directory)
(eq system-type 'windows-nt))
(mswindows-insert-directory file switches wildcard full-directory-p))
;;; 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))
;; ### This function is not compatible with FSF in some cases. Hard
;; to fix, because it is hard to trace the logic of the FSF function.
-;; In case we need the exact behaviour, we can always copy the FSF
+;; In case we need the exact behavior, we can always copy the FSF
;; version, which is very long and does lots of unnecessary stuff.
(defun truncate-string-to-width (str end-column &optional start-column padding)
"Truncate string STR to end at column END-COLUMN.
(make-obsolete 'function-called-at-point 'function-at-point)
+(provide 'obsolete)
;;; obsolete.el ends here
;; 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
(defun paths-find-lock-directory (roots)
"Find the lock directory."
+ (defvar configure-lock-directory)
(paths-find-site-directory roots "lock" "EMACSLOCKDIR" configure-lock-directory))
(defun paths-find-superlock-file (lock-directory)
"Find the superlock file."
+ ;; #### There is no such variable configure-superlock-file!
(cond
((null lock-directory)
nil)
;; 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.
(message "Back to top level.")
(setq command-line-processed t)
;; Canonicalize HOME (PWD is canonicalized by init_buffer in buffer.c)
- (unless (eq system-type 'vax-vms)
- (let ((value (user-home-directory)))
- (if (and value
- (< (length value) (length default-directory))
- (equal (file-attributes default-directory)
- (file-attributes value)))
- (setq default-directory (file-name-as-directory value)))))
+ (let ((value (user-home-directory)))
+ (if (and value
+ (< (length value) (length default-directory))
+ (equal (file-attributes default-directory)
+ (file-attributes value)))
+ (setq default-directory (file-name-as-directory value))))
(setq default-directory (abbreviate-file-name default-directory))
(initialize-xemacs-paths)
;; 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
;; `what(1)' can extract from the executable or a core file. We don't
;; actually need this to be pointed to from lisp; pure objects can't
;; be GCed.
-(or (memq system-type '(vax-vms windows-nt ms-dos))
+(or (memq system-type '(windows-nt ms-dos))
(purecopy (concat "\n@" "(#)" (emacs-version)
"\n@" "(#)" "Configuration: "
system-configuration "\n")))
;;; 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.
+1998-12-05 XEmacs Build Bot <builds@cvs.xemacs.org>
+
+ * XEmacs 21.2.5 is released
+
+1998-11-30 Martin Buchholz <martin@xemacs.org>
+
+ * xselect.c (receive_incremental_selection):
+ * xselect.c (x_get_window_property):
+ * xmu.c (XmuReadBitmapDataFromFile):
+ * xmu.c (XmuCursorNameToIndex):
+ * xgccache.c (describe_gc_cache):
+ * xgccache.c (gc_cache_lookup):
+ * xgccache.c (free_gc_cache):
+ * xgccache.c (make_gc_cache):
+ * window.h:
+ * window.c (map_windows_1):
+ * window.c (Fother_window_for_scrolling):
+ * window.c (window_scroll):
+ * window.c (change_window_height):
+ * window.c (Fsplit_window):
+ * window.c (window_left_gutter_width):
+ * window.c (window_modeline_height):
+ * window.c (invalidate_vertical_divider_cache_in_window):
+ * window.c (window_needs_vertical_divider_1):
+ * window.c (update_mirror_internal):
+ * window.c (SET_LAST_FACECHANGE):
+ * widget.c (Fwidget_plist_member):
+ * unexec.c (copy_text_and_data):
+ * unexcw.c (copy_executable_and_dump_data_section):
+ * tooltalk.doc:
+ * tooltalk.c (struct Lisp_Tooltalk_Pattern):
+ * tooltalk.c (struct Lisp_Tooltalk_Message):
+ * toolbar.h (struct toolbar_button):
+ * toolbar.c (default_toolbar_visible_p_changed_in_window):
+ * toolbar.c (recompute_overlaying_specifier):
+ * toolbar.c (toolbar_validate):
+ * toolbar.c (toolbar_button_at_pixpos):
+ * toolbar.c (get_toolbar_coords):
+ * toolbar.c (update_frame_toolbars):
+ * toolbar-x.c:
+ * toolbar-msw.c (mswindows_handle_toolbar_wm_command):
+ * toolbar-msw.c (mswindows_find_toolbar_pos):
+ * toolbar-msw.c (mswindows_output_toolbar):
+ * toolbar-msw.c (mswindows_clear_toolbar):
+ * toolbar-msw.c:
+ * systty.h:
+ * syssignal.h:
+ * sysproc.h:
+ * sysfile.h:
+ * sysdll.c:
+ * sysdep.h:
+ * sysdep.c (rmdir):
+ * sysdep.c (sys_fopen):
+ * sysdep.c (sys_open):
+ * sysdep.c (tty_init_sys_modes_on_device):
+ * sysdep.c (get_eof_char):
+ * sysdep.c (child_setup_tty):
+ * sysdep.c (set_descriptor_non_blocking):
+ * syntax.h:
+ * syntax.c (scan_words):
+ * syntax.c:
+ * symsinit.h:
+ * symeval.h (struct symbol_value_varalias):
+ * symeval.h (struct symbol_value_forward):
+ * symbols.c (syms_of_symbols):
+ * symbols.c (init_symbols_once_early):
+ * symbols.c (Fbuilt_in_variable_type):
+ * symbols.c (Fsymbol_value_in_buffer):
+ * symbols.c (default_value):
+ * symbols.c (Fset):
+ * symbols.c (find_symbol_value_quickly):
+ * symbols.c (store_symval_forwarding):
+ * symbols.c (set_default_console_slot_variable):
+ * symbols.c (set_default_buffer_slot_variable):
+ * symbols.c (verify_ok_for_buffer_local):
+ * symbols.c (symbol_is_constant):
+ * symbols.c (oblookup):
+ * symbols.c (Funintern):
+ * symbols.c (Fintern):
+ * symbols.c (check_obarray):
+ * sunplay.c:
+ * specifier.h (struct specifier_methods):
+ * specifier.h:
+ * specifier.c (specifier_instance):
+ * specifier.c (specifier_instance_from_inst_list):
+ * specifier.c (decode_locale_type):
+ * specifier.c (specifier_equal):
+ * specifier.c (finalize_specifier):
+ * specifier.c (prune_specifiers):
+ * specifier.c (kill_specifier_buffer_locals):
+ * sound.c (init_native_sound):
+ * sound.c:
+ * signal.c (alarm):
+ * search.c (Fmatch_data):
+ * search.c (match_limit):
+ * search.c (Freplace_match):
+ * search.c (skip_chars):
+ * search.c (scan_buffer):
+ * search.c:
+ * scrollbar.c (specifier_vars_of_scrollbar):
+ * scrollbar.c (Fscrollbar_set_hscroll):
+ * scrollbar.c (vertical_scrollbar_changed_in_window):
+ * scrollbar.c (release_window_mirror_scrollbars):
+ * scrollbar.c (free_scrollbar_instance):
+ * scrollbar-x.c:
+ * scrollbar-msw.c:
+ * s/msdos.h (O_BINARY):
+ * s/linux.h:
+ * s/freebsd.h (LIBS_TERMCAP):
+ * regex.c (re_match_2_internal):
+ * regex.c (compile_extended_range):
+ * regex.c (POP_FAILURE_POINT):
+ * regex.c (PUSH_FAILURE_POINT):
+ * redisplay.h (RESET_CHANGED_SET_FLAGS):
+ * redisplay.h:
+ * redisplay.h (struct display_line):
+ * redisplay.h (struct rune):
+ * redisplay.c (vars_of_redisplay):
+ * redisplay.c (redisplay_variable_changed):
+ * redisplay.c (UPDATE_CACHE_RETURN):
+ * redisplay.c (validate_line_start_cache):
+ * redisplay.c (mark_redisplay_structs):
+ * redisplay.c (mark_glyph_block_dynarr):
+ * redisplay.c (window_line_number):
+ * redisplay.c (redisplay_frame):
+ * redisplay.c (redisplay_window):
+ * redisplay.c (generate_modeline):
+ * redisplay.c (create_right_glyph_block):
+ * redisplay.c (create_left_glyph_block):
+ * redisplay.c (create_text_block):
+ * redisplay.c:
+ * redisplay-x.c (x_output_hline):
+ * redisplay-x.c (x_output_vertical_divider):
+ * redisplay-tty.c (tty_output_display_block):
+ * redisplay-output.c (output_display_line):
+ * redisplay-output.c:
+ * redisplay-msw.c (mswindows_output_vertical_divider):
+ * redisplay-msw.c (mswindows_ring_bell):
+ * redisplay-msw.c (mswindows_output_cursor):
+ * redisplay-msw.c:
+ * rangetab.c:
+ * ralloc.c:
+ * puresize.h (RAW_PURESIZE):
+ * profile.c (syms_of_profile):
+ * profile.c (Fstart_profiling):
+ * profile.c (sigprof_handler):
+ * profile.c:
+ * procimpl.h:
+ * process.c (vars_of_process):
+ * process.c (read_process_output):
+ * process.c (get_process):
+ * process.c:
+ * process-unix.c (unix_open_multicast_group):
+ * process-unix.c (unix_get_tty_name):
+ * process-unix.c (unix_send_process):
+ * process-unix.c (unix_reap_exited_processes):
+ * process-unix.c (unix_create_process):
+ * process-unix.c (unix_init_process_io_handles):
+ * process-unix.c (allocate_pty):
+ * process-unix.c:
+ * process-nt.c (nt_open_network_stream):
+ * process-nt.c (nt_update_status_if_terminated):
+ * process-nt.c (nt_finalize_process_data):
+ * process-nt.c:
+ * print.c (debug_short_backtrace):
+ * print.c (debug_backtrace):
+ * print.c (print_symbol):
+ * print.c (print_internal):
+ * print.c (print_cons):
+ * print.c (Fwrite_char):
+ * print.c (print_prepare):
+ * print.c (canonicalize_printcharfun):
+ * print.c (output_string):
+ * print.c:
+ * opaque.h:
+ * opaque.c (allocate_managed_opaque):
+ * opaque.c:
+ * offix.c (DndSetData):
+ * objects.c (face_boolean_create):
+ * objects.c (font_instantiate):
+ * objects.c (font_create):
+ * objects.c (color_create):
+ * objects.c (finalize_font_instance):
+ * objects.c (finalize_color_instance):
+ * objects.c:
+ * objects-x.c (x_font_instance_truename):
+ * objects-x.c:
+ * objects-x.c (x_initialize_font_instance):
+ * objects-x.c (allocate_nearest_color):
+ * objects-tty.c (tty_initialize_font_instance):
+ * objects-tty.c (tty_initialize_color_instance):
+ * objects-msw.c (mswindows_initialize_color_instance):
+ * ntproc.c (syms_of_ntproc):
+ * ntproc.c (Fwin32_set_process_priority):
+ * ntproc.c (sys_spawnve):
+ * ntproc.c:
+ * ntheap.c (get_data_end):
+ * nt.c (period):
+ * nt.c:
+ * nt.c (stat):
+ * nt.c (generate_inode_val):
+ * nt.c (sys_rename):
+ * nas.c:
+ * mule-wnnfns.c (Fwnn_hinsi_number):
+ * mule-wnnfns.c (Fwnn_yuragi):
+ * mule-wnnfns.c (Fwnn_common_learn):
+ * mule-wnnfns.c (Fwnn_suffix_learn):
+ * mule-wnnfns.c (Fwnn_prefix_learn):
+ * mule-wnnfns.c (Fwnn_okuri_learn):
+ * mule-wnnfns.c (Fwnn_complex_conv):
+ * mule-wnnfns.c (Fwnn_last_is_first):
+ * mule-wnnfns.c (Fwnn_bmodify_dict_add):
+ * mule-wnnfns.c (Fwnn_notrans_dict_add):
+ * mule-wnnfns.c (Fwnn_fiusr_dict_add):
+ * mule-wnnfns.c (Fwnn_fisys_dict_add):
+ * mule-wnnfns.c (Fwnn_hinsi_list):
+ * mule-wnnfns.c (Fwnn_fuzokugo_set):
+ * mule-wnnfns.c (Fwnn_dict_search):
+ * mule-wnnfns.c (Fwnn_word_toroku):
+ * mule-wnnfns.c (Fwnn_hindo_update):
+ * mule-wnnfns.c (Fwnn_bunsetu_henkou):
+ * mule-wnnfns.c (Fwnn_kakutei):
+ * mule-wnnfns.c (Fwnn_begin_henkan):
+ * mule-wnnfns.c (Fwnn_dict_comment):
+ * mule-wnnfns.c (Fwnn_dict_add):
+ * mule-wnnfns.c (Fwnn_open):
+ * mule-mcpath.c (mc_getcwd):
+ * mule-coding.c (vars_of_mule_coding):
+ * mule-coding.c (convert_to_external_format):
+ * mule-coding.c (encoding_marker):
+ * mule-coding.c (decoding_marker):
+ * mule-coding.c (Fcopy_coding_system):
+ * mule-coding.c (Fmake_coding_system):
+ * mule-coding.c (Fcoding_system_list):
+ * mule-coding.c (Ffind_coding_system):
+ * mule-coding.c (symbol_to_eol_type):
+ * mule-coding.c:
+ * mule-charset.c (complex_vars_of_mule_charset):
+ * mule-charset.c (vars_of_mule_charset):
+ * mule-charset.c (Fset_charset_ccl_program):
+ * mule-charset.c (struct charset_list_closure):
+ * mule-charset.c (Ffind_charset):
+ * mule-charset.c (make_charset):
+ * mule-charset.c (non_ascii_valid_char_p):
+ * mule-charset.c:
+ * mule-ccl.c (ccl_driver):
+ * mule-canna.c (c2mu):
+ * mule-canna.c (Fcanna_henkan_begin):
+ * mule-canna.c (Fcanna_parse):
+ * mule-canna.c (Fcanna_store_yomi):
+ * mule-canna.c (Fcanna_touroku_string):
+ * mule-canna.c (Fcanna_initialize):
+ * minibuf.c:
+ * menubar.c (menu_parse_submenu_keywords):
+ * menubar-x.c (make_dummy_xbutton_event):
+ * menubar-x.c (set_frame_menubar):
+ * menubar-x.c (menu_item_descriptor_to_widget_value_1):
+ * menubar-x.c:
+ * menubar-msw.h:
+ * menubar-msw.c (mswindows_popup_menu):
+ * menubar-msw.c (mswindows_update_frame_menubars):
+ * menubar-msw.c (mswindows_handle_wm_command):
+ * menubar-msw.c (unsafe_handle_wm_initmenu_1):
+ * menubar-msw.c (unsafe_handle_wm_initmenupopup_1):
+ * menubar-msw.c (update_frame_menubar_maybe):
+ * menubar-msw.c (populate_or_checksum_helper):
+ * menubar-msw.c (empty_menu):
+ * menubar-msw.c:
+ * md5.c:
+ * marker.c (set_marker_internal):
+ * marker.c (print_marker):
+ * malloc.c:
+ * make-src-depend:
+ * lstream.c (lisp_buffer_rewinder):
+ * lstream.c (mark_lstream):
+ * lrecord.h:
+ * lrecord.h (struct lrecord_header):
+ * lread.c (readevalloop):
+ * lread.c (locate_file):
+ * lread.c (locate_file_in_directory):
+ * lread.c (Flocate_file):
+ * lread.c (load_force_doc_string_unwind):
+ * lread.c (ebolify_bytecode_constants):
+ * lread.c:
+ * lisp.h:
+ * lisp-union.h:
+ * lisp-disunion.h:
+ * linuxplay.c (linux_play_data_or_file):
+ * linuxplay.c (audio_init):
+ * line-number.c:
+ * keymap.h:
+ * keymap.c (describe_map):
+ * keymap.c (describe_map_mapper):
+ * keymap.c (Fdescribe_bindings_internal):
+ * keymap.c (Fsingle_key_description):
+ * keymap.c (map_keymap_sorted):
+ * keymap.c (get_relevant_keymaps):
+ * keymap.c (Flookup_key):
+ * keymap.c (raw_lookup_key_mapper):
+ * keymap.c (Fdefine_key):
+ * keymap.c (Fevent_matches_key_specifier_p):
+ * keymap.c (key_desc_list_to_event):
+ * keymap.c (define_key_parser):
+ * keymap.c (define_key_check_and_coerce_keysym):
+ * keymap.c (keymap_submaps):
+ * keymap.c (keymap_store_internal):
+ * keymap.c (keymap_delete_inverse_internal):
+ * keymap.c (keymap_store_inverse_internal):
+ * keymap.c (print_keymap):
+ * keymap.c (Lisp_Keymap):
+ * keymap.c:
+ * intl.c:
+ * insdel.c (convert_bufbyte_string_into_emchar_dynarr):
+ * insdel.c (make_gap):
+ * input-method-xlib.c (get_XIM_input):
+ * input-method-xlib.c (XIM_init_frame):
+ * imgproc.c:
+ * hash.h:
+ * hash.c:
+ * gui.c:
+ * gui-x.c (button_item_to_widget_value):
+ * gui-x.c (popup_selection_callback):
+ * glyphs.h (struct image_instantiator_methods):
+ * glyphs.c (mark_glyph_cachels):
+ * glyphs.c (Fglyph_type):
+ * glyphs.c (image_instantiate):
+ * glyphs.c (image_create):
+ * glyphs.c (make_image_instance_1):
+ * glyphs.c (finalize_image_instance):
+ * glyphs.c:
+ * glyphs-x.c (finalize_subwindow):
+ * glyphs-x.c (xface_validate):
+ * glyphs-x.c (x_locate_pixmap_file):
+ * glyphs-x.c (convert_EImage_to_XImage):
+ * glyphs-msw.c:
+ * glyphs-msw.c (mswindows_resource_instantiate):
+ * glyphs-msw.c (xpm_to_eimage):
+ * glyphs-msw.c (convert_EImage_to_DIBitmap):
+ * glyphs-eimage.c (tiff_instantiate):
+ * glyphs-eimage.c (png_instantiate):
+ * glyphs-eimage.c (struct png_error_struct):
+ * glyphs-eimage.c (gif_memory_storage):
+ * glyphs-eimage.c:
+ * gifrlib.h:
+ * getloadavg.c (getloadavg):
+ * getloadavg.c:
+ * gdbinit:
+ * free-hook.c (log_gcpro):
+ * free-hook.c (check_malloc):
+ * free-hook.c (check_free):
+ * free-hook.c (ROUND_UP_TO_PAGE):
+ * free-hook.c:
+ * frame.h (struct frame):
+ * frame.h:
+ * frame.c (change_frame_size_1):
+ * frame.c (allocate_frame_core):
+ * frame.c:
+ * frame-x.c (x_focus_on_frame):
+ * frame-x.c (x_init_frame_2):
+ * frame-x.c (x_popup_frame):
+ * frame-x.c (xemacs_XtPopup):
+ * frame-x.c:
+ * frame-x.c (Foffix_start_drag_internal):
+ * frame-x.c (x_cde_destroy_callback):
+ * frame-x.c (x_wm_hack_wm_protocols):
+ * frame-tty.c (tty_frame_visible_p):
+ * frame-msw.c (mswindows_make_frame_invisible):
+ * frame-msw.c (mswindows_after_init_frame):
+ * frame-msw.c (mswindows_init_frame_1):
+ * fns.c (syms_of_fns):
+ * fns.c (Fbase64_decode_string):
+ * fns.c (Fnconc):
+ * fns.c (Ffillarray):
+ * fns.c (Fobject_plist):
+ * fns.c (Fget):
+ * fns.c (Fcanonicalize_lax_plist):
+ * fns.c (Fcanonicalize_plist):
+ * fns.c (Fplist_remprop):
+ * fns.c (Fplist_get):
+ * fns.c (advance_plist_pointers):
+ * fns.c (internal_plist_put):
+ * fns.c (Fnreverse):
+ * fns.c (Fremassq):
+ * fns.c (Felt):
+ * fns.c (Fsubstring):
+ * fns.c (Fbvconcat):
+ * fns.c (Flength):
+ * fns.c (length_with_bytecode_hack):
+ * fns.c (print_bit_vector):
+ * fns.c:
+ * floatfns.c (Ffloor):
+ * floatfns.c:
+ * floatfns.c (in_float_error):
+ * fileio.c (Ffile_modes):
+ * fileio.c (Fexpand_file_name):
+ * fileio.c (Fmake_temp_name):
+ * fileio.c (Ffile_name_nondirectory):
+ * fileio.c (Ffile_name_directory):
+ * file-coding.h:
+ * file-coding.c (vars_of_mule_coding):
+ * file-coding.c (convert_to_external_format):
+ * file-coding.c (encoding_marker):
+ * file-coding.c (decoding_marker):
+ * file-coding.c (Fcopy_coding_system):
+ * file-coding.c (Fmake_coding_system):
+ * file-coding.c (struct coding_system_list_closure):
+ * file-coding.c (Ffind_coding_system):
+ * file-coding.c (symbol_to_eol_type):
+ * file-coding.c:
+ * faces.h (struct face_cachel):
+ * faces.c (vars_of_faces):
+ * faces.c (face_property_was_changed):
+ * faces.c (mark_face_cachels):
+ * faces.c (temporary_faces_list):
+ * faces.c (struct face_list_closure):
+ * faces.c:
+ * extents.h (struct extent):
+ * extents.c (vars_of_extents):
+ * extents.c (struct copy_string_extents_1_arg):
+ * extents.c (add_string_extents_mapper):
+ * extents.c (Fextent_property):
+ * extents.c (Fset_extent_property):
+ * extents.c (symbol_to_glyph_layout):
+ * extents.c (properties_equal):
+ * extents.c (print_extent):
+ * extents.c (print_extent_1):
+ * extents.c (extent_in_region_p):
+ * extents.c (gap_array_make_gap):
+ * extents.c:
+ * events.h (struct Lisp_Event):
+ * events.h:
+ * events.c (Fevent_properties):
+ * events.c (format_event_object):
+ * events.c (Fmake_event):
+ * events.c (event_equal):
+ * events.c (print_event):
+ * events.c (mark_event):
+ * event-stream.c ((read-char)
+ * event-stream.c (vars_of_event_stream):
+ * event-stream.c (syms_of_event_stream):
+ * event-stream.c (Fset_recent_keys_ring_size):
+ * event-stream.c (Fsit_for):
+ * event-stream.c (Fnext_event):
+ * event-stream.c (execute_help_form):
+ * event-stream.c (maybe_kbd_translate):
+ * event-stream.c:
+ * event-msw.c (vars_of_event_mswindows):
+ * event-msw.c (mswindows_wnd_proc):
+ * event-msw.c (mswindows_need_event):
+ * event-msw.c (mswindows_drain_windows_queue):
+ * event-msw.c (mswindows_pump_outstanding_events):
+ * event-msw.c:
+ * event-msw.c (slurp_thread):
+ * event-msw.c (struct ntpipe_slurp_stream):
+ * event-msw.c (HANDLE_TO_USID):
+ * event-Xt.c (emacs_Xt_handle_magic_event):
+ * event-Xt.c (x_event_to_emacs_event):
+ * event-Xt.c (x_reset_modifier_mapping):
+ * event-Xt.c (x_reset_key_mapping):
+ * event-Xt.c:
+ * eval.c (syms_of_eval):
+ * eval.c (warn_when_safe):
+ * eval.c (warn_when_safe_lispobj):
+ * eval.c (Fbacktrace_frame):
+ * eval.c (Fbacktrace):
+ * eval.c (top_level_set):
+ * eval.c (unbind_to_hairy):
+ * eval.c (specbind_magic):
+ * eval.c (specbind_unwind_wasnt_local):
+ * eval.c (call2_trapping_errors):
+ * eval.c (call1_trapping_errors):
+ * eval.c (catch_them_squirmers_call2):
+ * eval.c (call0_trapping_errors):
+ * eval.c (run_hook_trapping_errors):
+ * eval.c (catch_them_squirmers_eval_in_buffer):
+ * eval.c (call4_in_buffer):
+ * eval.c (call3_in_buffer):
+ * eval.c (call2_in_buffer):
+ * eval.c (call1_in_buffer):
+ * eval.c (call0_in_buffer):
+ * eval.c (run_hook):
+ * eval.c (run_hook_with_args_in_buffer):
+ * eval.c (Fapply):
+ * eval.c (Feval):
+ * eval.c (do_autoload):
+ * eval.c (un_autoload):
+ * eval.c (Fautoload):
+ * eval.c (Finteractive_p):
+ * eval.c (Fcommand_execute):
+ * eval.c (signal_quit):
+ * eval.c (call_with_suspended_errors):
+ * eval.c (signal_error):
+ * eval.c (return_from_signal):
+ * eval.c (Fcall_with_condition_handler):
+ * eval.c (run_condition_case_handlers):
+ * eval.c (condition_case_1):
+ * eval.c (Funwind_protect):
+ * eval.c (unwind_to_catch):
+ * eval.c (internal_catch):
+ * eval.c (Fmacroexpand_internal):
+ * eval.c (Fuser_variable_p):
+ * eval.c (Fdefconst):
+ * eval.c (Fdefvar):
+ * eval.c (Ffunction):
+ * eval.c (signal_call_debugger):
+ * eval.c (call_debugger):
+ * eval.c:
+ * emacs.c (main):
+ * emacs.c (sort_args):
+ * emacs.c (main_1):
+ * elhash.h:
+ * elhash.c:
+ * editfns.c (Fencode_time):
+ * editfns.c (Fdecode_time):
+ * editfns.c (Fuser_full_name):
+ * editfns.c:
+ * editfns.c (save_excursion_restore):
+ * ecrt0.c:
+ * dynarr.c:
+ * doprnt.c (emacs_doprnt_1):
+ * doc.c (verify_doc_mapper):
+ * doc.c (Fsnarf_documentation):
+ * doc.c (Fdocumentation):
+ * dll.c:
+ * dired.c (user_name_completion):
+ * dired.c (Fdirectory_files):
+ * dialog-x.c:
+ * dialog-msw.c:
+ * dgif_lib.c (FreeSavedImages):
+ * dgif_lib.c (DGifGetImageDesc):
+ * device.h:
+ * device.h (struct device):
+ * device.c (Fselect_device):
+ * device.c (allocate_device):
+ * device.c:
+ * device-x.c (Fx_keysym_on_keyboard_p):
+ * device-x.c (Fx_valid_keysym_name_p):
+ * device-x.c (x_IO_error_handler):
+ * device-x.c (x_delete_device):
+ * device-x.c (x_finish_init_device):
+ * device-x.c (x_init_device):
+ * device-x.c:
+ * device-msw.c (mswindows_init_device):
+ * dbxrc:
+ * database.c (vars_of_database):
+ * database.c (Fput_database):
+ * database.c (Fopen_database):
+ * database.c (berkdb_remove):
+ * database.c (berkdb_put):
+ * database.c (Fdatabasep):
+ * database.c (print_database):
+ * database.c:
+ * data.c (vars_of_data):
+ * data.c (syms_of_data):
+ * data.c (init_errors_once_early):
+ * data.c (prune_weak_lists):
+ * data.c (finish_marking_weak_lists):
+ * data.c (print_weak_list):
+ * data.c (Fmod):
+ * data.c (Fstring_to_number):
+ * data.c (Fnumber_to_string):
+ * data.c (Findirect_function):
+ * data.c (Fsetcdr):
+ * data.c (Ffloatp):
+ * data.c (Fsubr_interactive):
+ * data.c (Farrayp):
+ * data.c (Fkeywordp):
+ * data.c (Fnull):
+ * data.c:
+ * console.h (CONSOLE_NAME):
+ * console.h:
+ * console.c (vars_of_console):
+ * console.c (Fselect_console):
+ * console.c:
+ * console-x.h (DEVICE_X_COLORMAP):
+ * console-x.h (struct x_device):
+ * console-x.c (x_device_to_console_connection):
+ * console-tty.h (CONSOLE_TTY_FINAL_CURSOR_Y):
+ * console-tty.c (tty_init_console):
+ * console-tty.c:
+ * console-msw.h (struct mswindows_frame):
+ * conslots.h:
+ * config.h.in:
+ * cmds.c (internal_self_insert):
+ * cmds.c (Fforward_line):
+ * cmds.c (Fforward_char):
+ * cmds.c:
+ * cmdloop.c:
+ * chartab.c (mark_char_table_entry):
+ * chartab.c:
+ * casefiddle.c (casify_word):
+ * callproc.c (child_setup):
+ * callproc.c (Fcall_process_internal):
+ * callproc.c:
+ * callint.c (Fcall_interactively):
+ * bytecode.h:
+ * bytecode.c (execute_rare_opcode):
+ * bytecode.c (execute_optimized_program):
+ * bytecode.c:
+ * bufslots.h:
+ * buffer.h (BUFFER_REALLOC):
+ * buffer.h (GET_CHARPTR_INT_DATA_ALLOCA):
+ * buffer.h (GET_CHARPTR_EXT_DATA_ALLOCA):
+ * buffer.h:
+ * buffer.h (MAP_INDIRECT_BUFFERS):
+ * buffer.h (CHECK_LIVE_BUFFER):
+ * buffer.c (init_initial_directory):
+ * buffer.c (complex_vars_of_buffer):
+ * buffer.c (vars_of_buffer):
+ * buffer.c (finish_init_buffer):
+ * buffer.c (Fget_file_buffer):
+ * buffer.c (Fbuffer_list):
+ * buffer.c (mark_buffer):
+ * balloon_help.c (balloon_help_move_to_pointer):
+ * balloon_help.c (show_help):
+ * balloon_help.c:
+ * backtrace.h:
+ * alloc.c (garbage_collect_1):
+ * alloc.c (sweep_strings):
+ * alloc.c (sweep_compiled_functions):
+ * alloc.c (sweep_bit_vectors_1):
+ * alloc.c (sweep_vectors_1):
+ * alloc.c (sweep_lcrecords_1):
+ * alloc.c (tick_lcrecord_stats):
+ * alloc.c (pure_string_sizeof):
+ * alloc.c (mark_conses_in_list):
+ * alloc.c (mark_object):
+ * alloc.c (report_pure_usage):
+ * alloc.c (make_pure_float):
+ * alloc.c (make_pure_string):
+ * alloc.c (free_managed_lcrecord):
+ * alloc.c (mark_string):
+ * alloc.c (noseeum_make_marker):
+ * alloc.c (allocate_event):
+ * alloc.c (Fbit_vector):
+ * alloc.c (Fvector):
+ * alloc.c (make_float):
+ * alloc.c (Fmake_list):
+ * alloc.c (Flist):
+ * alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
+ * alloc.c (PUT_FIXED_TYPE_ON_FREE_LIST):
+ * alloc.c (DECLARE_FIXED_TYPE_ALLOC):
+ * alloc.c (dbg_constants):
+ * alloc.c (gc_record_type_p):
+ * alloc.c (free_lcrecord):
+ * alloc.c (xmalloc):
+ * alloc.c (NOSEEUM_INCREMENT_CONS_COUNTER):
+ * abbrev.c:
+ * Makefile.in.in (mostlyclean):
+ * Makefile.in.in (external_client_xlib_objs_nonshared):
+ * Makefile.in.in (temacs_link_args):
+ * Makefile.in.in (release):
+ * Makefile.in.in (dnd_objs):
+ * Makefile.in.in (objs):
+ * Makefile.in.in (PROGNAME):
+ * EmacsShell.c: cast strings to (XtPointer)
+ * EmacsFrame.c: cast strings to (XtPointer)
+ - mega patch
+ - rewrite basic lisp functions for speed
+ - rewrite bytecode interpreter for speed
+ - rewrite list looping constructs for speed and safety using
+ tortoise/hare.
+ - use size_t where appropriate.
+ - new hashtable implementation
+ - cleanup implementation of opaques
+ - opaques can now be purecopy'ed
+ - move some cl functionality into C for speed.
+ - remove last remaining VMS support
+ - spelling fixes
+ - improve gdb/dbx debugger support
+ - move pure.c back into alloc.c for performance
+ - enable report_pure_usage() if --memory-usage-stats
+ - remove remnants of Energize support (EMACS_BTL, cadillac...)
+ - don't use symbols with leading `_' or embedded `__'
+ - globally cleanup duplicated semicolons `;;'
+ - I give in on %p vs %lx - we use printf("%lx",(long) p)
+ globally.
+ - globally replace O_NDELAY with O_NONBLOCK.
+ - globally replace CDISABLE with _POSIX_VDISABLE.
+ - use O_RDONLY and O_RDWR instead of magic `0' and `2'.
+ - define (and maybe use!) STDERR_FILENO and friends.
+ - add support for macros defined in C
+ - `when', `unless', `not' and `defalias' now defined in C,
+ so that they are universally available.
+ - rename defvar_mumble to defvar_magic
+ - rename RETURN__ to RETURN_SANS_WARNINGS
+ - use consistent style of initial caps in error messages
+ - implement last, butlast, nbutlast, copy-list in C.
+ - provide typedefs for all struct Lisp_foo types
+ - Lisp_Objects must be initialized to Qnil rather than 0.
+ - make sure XEmacs runs (slowly) with always_gc == 1;
+ - fast and safe LOOP_* macros
+ - change calls to XSETOBJ to XSETFOO
+ - replace calls to XSETINT by make_int()
+ - plug up memory leaks
+ - use style markobj (foo), not silly ((markobj) (foo))
+ - use XFLOAT_DATA (obj) instead of float_data (XFLOAT (obj))
+
+1998-12-02 P. E. Jareth Hein <jareth@camelot.co.jp>
+
+ * unexec.c: Changed a #ifndef statement to fix XEmacs on BSDI 3.0
+
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
It is an order of magnitude faster than the proper abbrev_match(),
but then again, vi is an order of magnitude faster than Emacs.
- This speed difference should be unnoticable, though. I have tested
+ This speed difference should be unnoticeable, though. I have tested
the degenerated cases of thousands of abbrevs being defined, and
abbrev_match() was still fast enough for normal operation. */
static struct Lisp_Symbol *
#include "extents.h"
#include "frame.h"
#include "glyphs.h"
+#include "opaque.h"
#include "redisplay.h"
#include "specifier.h"
#include "sysfile.h"
/* Define this to see where all that space is going... */
/* But the length of the printout is obnoxious, so limit it to testers */
-/* If somebody wants to see this they can ask for it.
-#ifdef DEBUG_XEMACS
+#ifdef MEMORY_USAGE_STATS
#define PURESTAT
#endif
-*/
/* Define this to use malloc/free with no freelist for all datatypes,
the hope being that some debugging tools may help detect
#include "puresize.h"
#ifdef DEBUG_XEMACS
-int debug_allocation;
-
-int debug_allocation_backtrace_length;
+static int debug_allocation;
+static int debug_allocation_backtrace_length;
#endif
/* Number of bytes of consing done since the last gc */
EMACS_INT consing_since_gc;
-#ifdef EMACS_BTL
-extern void cadillac_record_backtrace ();
-#define INCREMENT_CONS_COUNTER_1(size) \
- do { \
- EMACS_INT __sz__ = ((EMACS_INT) (size)); \
- consing_since_gc += __sz__; \
- cadillac_record_backtrace (2, __sz__); \
- } while (0)
-#else
#define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
-#endif /* EMACS_BTL */
#define debug_allocation_backtrace() \
do { \
INCREMENT_CONS_COUNTER_1 (size)
#endif
-#define DECREMENT_CONS_COUNTER(size) \
- do { \
- EMACS_INT __sz__ = ((EMACS_INT) (size)); \
- if (consing_since_gc >= __sz__) \
- consing_since_gc -= __sz__; \
- else \
- consing_since_gc = 0; \
- } while (0)
+#define DECREMENT_CONS_COUNTER(size) do { \
+ consing_since_gc -= (size); \
+ if (consing_since_gc < 0) \
+ consing_since_gc = 0; \
+} while (0)
/* Number of bytes of consing since gc before another gc should be done. */
EMACS_INT gc_cons_threshold;
extern void sheap_adjust_h();
#endif
+/* Force linker to put it into data space! */
+EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0};
+
#define PUREBEG ((char *) pure)
#if 0 /* This is breathing_space in XEmacs */
((char *) (ptr) >= PUREBEG && \
(char *) (ptr) < PUREBEG + get_PURESIZE())
-/* Non-zero if pure_bytes_used > get_PURESIZE(); accounts for excess purespace needs. */
+/* Non-zero if pure_bytes_used > get_PURESIZE();
+ accounts for excess purespace needs. */
static size_t pure_lossage;
#ifdef ERROR_CHECK_TYPECHECK
#else /* PURESTAT */
-static int purecopying_for_bytecode;
+static int purecopying_function_constants;
-static size_t pure_sizeof (Lisp_Object /*, int recurse */);
+static size_t pure_sizeof (Lisp_Object);
/* Keep statistics on how much of what is in purespace */
static struct purestat
purestat_cons = {0, 0, "cons cells"},
purestat_float = {0, 0, "float objects"},
purestat_string_pname = {0, 0, "symbol-name strings"},
- purestat_bytecode = {0, 0, "compiled-function objects"},
- purestat_string_bytecodes = {0, 0, "byte-code strings"},
- purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"},
+ purestat_function = {0, 0, "compiled-function objects"},
+ purestat_opaque_instructions = {0, 0, "compiled-function instructions"},
+ purestat_vector_constants = {0, 0, "compiled-function constants vectors"},
purestat_string_interactive = {0, 0, "interactive strings"},
#ifdef I18N3
purestat_string_domain = {0, 0, "domain strings"},
purestat_string_all = {0, 0, "all strings"},
purestat_vector_all = {0, 0, "all vectors"};
-static struct purestat *purestats[] =
-{
- &purestat_cons,
- &purestat_float,
- &purestat_string_pname,
- &purestat_bytecode,
- &purestat_string_bytecodes,
- &purestat_vector_bytecode_constants,
- &purestat_string_interactive,
-#ifdef I18N3
- &purestat_string_domain,
-#endif
- &purestat_string_documentation,
- &purestat_string_other_function,
- &purestat_vector_other,
- &purestat_string_other,
- 0,
- &purestat_string_all,
- &purestat_vector_all
-};
-
static void
bump_purestat (struct purestat *purestat, size_t nbytes)
{
purestat->nobjects += 1;
purestat->nbytes += nbytes;
}
+
+static void
+print_purestat (struct purestat *purestat)
+{
+ char buf [100];
+ sprintf(buf, "%s:", purestat->name);
+ message (" %-36s %5d %7d %2d%%",
+ buf,
+ purestat->nobjects,
+ purestat->nbytes,
+ (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5));
+}
#endif /* PURESTAT */
\f
/* Maximum amount of C stack to save when a GC happens. */
#ifndef MAX_SAVE_STACK
-#define MAX_SAVE_STACK 16000
+#define MAX_SAVE_STACK 0 /* 16000 */
#endif
/* Non-zero means ignore malloc warnings. Set during initialization. */
return val;
}
+static void *
+xcalloc (size_t nelem, size_t elsize)
+{
+ void *val = (void *) calloc (nelem, elsize);
+
+ if (!val && (nelem != 0)) memory_full ();
+ return val;
+}
+
void *
xmalloc_and_zero (size_t size)
{
- void *val = xmalloc (size);
- memset (val, 0, size);
- return val;
+ return xcalloc (size, sizeof (char));
}
#ifdef xrealloc
{
struct lcrecord_header *lcheader;
- if (size <= 0) abort ();
+#ifdef ERROR_CHECK_GC
if (implementation->static_size == 0)
- {
- if (!implementation->size_in_bytes_method)
- abort ();
- }
- else if (implementation->static_size != size)
- abort ();
+ assert (implementation->size_in_bytes_method);
+ else
+ assert (implementation->static_size == size);
+#endif
lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
- set_lheader_implementation(&(lcheader->lheader), implementation);
+ set_lheader_implementation (&(lcheader->lheader), implementation);
lcheader->next = all_lcrecords;
#if 1 /* mly prefers to see small ID numbers */
lcheader->uid = lrecord_uid_counter++;
}
}
if (lrecord->implementation->finalizer)
- ((lrecord->implementation->finalizer) (lrecord, 0));
+ lrecord->implementation->finalizer (lrecord, 0);
xfree (lrecord);
return;
}
}
\f
-/**********************************************************************/
-/* Debugger support */
-/**********************************************************************/
+/************************************************************************/
+/* Debugger support */
+/************************************************************************/
/* Give gdb/dbx enough information to decode Lisp Objects.
We make sure certain symbols are defined, so gdb doesn't complain
about expressions in src/gdbinit. Values are randomly chosen.
dbg_USE_MINIMAL_TAGBITS = 0,
dbg_Lisp_Type_Int = Lisp_Type_Int,
#endif /* ! USE_MIMIMAL_TAGBITS */
+
+#ifdef USE_UNION_TYPE
+ dbg_USE_UNION_TYPE = 1,
+#else
+ dbg_USE_UNION_TYPE = 0,
+#endif
+
#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1,
#else
dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0,
#endif
+
dbg_Lisp_Type_Char = Lisp_Type_Char,
dbg_Lisp_Type_Record = Lisp_Type_Record,
#ifdef LRECORD_CONS
other compilers) might optimize away the entire type declaration :-( */
} dbg_dummy;
+/* A few macros turned into functions for ease of debugging.
+ Debuggers don't know about macros! */
+int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
+int
+dbg_eq (Lisp_Object obj1, Lisp_Object obj2)
+{
+ return EQ (obj1, obj2);
+}
+
\f
-/**********************************************************************/
-/* Fixed-size type macros */
-/**********************************************************************/
+/************************************************************************/
+/* Fixed-size type macros */
+/************************************************************************/
/* For fixed-size types that are commonly used, we malloc() large blocks
of memory at a time and subdivide them into chunks of the correct
/ sizeof (structtype))
#endif /* ALLOC_NO_POOLS */
-#define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
- \
-struct type##_block \
-{ \
- struct type##_block *prev; \
- structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
-}; \
- \
-static struct type##_block *current_##type##_block; \
-static int current_##type##_block_index; \
- \
-static structtype *type##_free_list; \
-static structtype *type##_free_list_tail; \
- \
-static void \
-init_##type##_alloc (void) \
-{ \
- current_##type##_block = 0; \
- current_##type##_block_index = countof (current_##type##_block->block); \
- type##_free_list = 0; \
- type##_free_list_tail = 0; \
-} \
- \
-static int gc_count_num_##type##_in_use, gc_count_num_##type##_freelist
-
-#define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \
- do { \
- if (current_##type##_block_index \
- == countof (current_##type##_block->block)) \
+#define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \
+ \
+struct type##_block \
+{ \
+ struct type##_block *prev; \
+ structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \
+}; \
+ \
+static struct type##_block *current_##type##_block; \
+static int current_##type##_block_index; \
+ \
+static structtype *type##_free_list; \
+static structtype *type##_free_list_tail; \
+ \
+static void \
+init_##type##_alloc (void) \
+{ \
+ current_##type##_block = 0; \
+ current_##type##_block_index = \
+ countof (current_##type##_block->block); \
+ type##_free_list = 0; \
+ type##_free_list_tail = 0; \
+} \
+ \
+static int gc_count_num_##type##_in_use; \
+static int gc_count_num_##type##_freelist
+
+#define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \
+ if (current_##type##_block_index \
+ == countof (current_##type##_block->block)) \
{ \
- struct type##_block *__new__ = (struct type##_block *) \
- allocate_lisp_storage (sizeof (struct type##_block)); \
- __new__->prev = current_##type##_block; \
- current_##type##_block = __new__; \
+ struct type##_block *AFTFB_new = (struct type##_block *) \
+ allocate_lisp_storage (sizeof (struct type##_block)); \
+ AFTFB_new->prev = current_##type##_block; \
+ current_##type##_block = AFTFB_new; \
current_##type##_block_index = 0; \
} \
- (result) = \
- &(current_##type##_block->block[current_##type##_block_index++]); \
- } while (0)
+ (result) = \
+ &(current_##type##_block->block[current_##type##_block_index++]); \
+} while (0)
/* Allocate an instance of a type that is stored in blocks.
TYPE is the "name" of the type, STRUCTTYPE is the corresponding
#else /* !ERROR_CHECK_GC */
#define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
-do { * (structtype **) ((char *) ptr + sizeof (void *)) = \
+do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \
type##_free_list; \
- type##_free_list = ptr; \
+ type##_free_list = (ptr); \
} while (0)
#endif /* !ERROR_CHECK_GC */
/* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
-#define FREE_FIXED_TYPE(type, structtype, ptr) \
-do { structtype *_weird_ = (ptr); \
- ADDITIONAL_FREE_##type (_weird_); \
- deadbeef_memory (ptr, sizeof (structtype)); \
- PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, ptr); \
- MARK_STRUCT_AS_FREE (_weird_); \
- } while (0)
+#define FREE_FIXED_TYPE(type, structtype, ptr) do { \
+ structtype *FFT_ptr = (ptr); \
+ ADDITIONAL_FREE_##type (FFT_ptr); \
+ deadbeef_memory (FFT_ptr, sizeof (structtype)); \
+ PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
+ MARK_STRUCT_AS_FREE (FFT_ptr); \
+} while (0)
/* Like FREE_FIXED_TYPE() but used when we are explicitly
freeing a structure through free_cons(), free_marker(), etc.
\f
-/**********************************************************************/
-/* Cons allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Cons allocation */
+/************************************************************************/
DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons);
/* conses are used and freed so often that we set this really high */
static Lisp_Object
mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
- if (NILP (XCDR (obj)))
+ if (GC_NILP (XCDR (obj)))
return XCAR (obj);
- (markobj) (XCAR (obj));
+ markobj (XCAR (obj));
return XCDR (obj);
}
Lisp_Object val = Qnil;
Lisp_Object *argp = args + nargs;
- while (nargs-- > 0)
+ while (argp > args)
val = Fcons (*--argp, val);
return val;
}
}
\f
-/**********************************************************************/
-/* Float allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Float allocation */
+/************************************************************************/
#ifdef LISP_FLOAT_TYPE
#endif /* LISP_FLOAT_TYPE */
\f
-/**********************************************************************/
-/* Vector allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Vector allocation */
+/************************************************************************/
#ifdef LRECORD_VECTOR
static Lisp_Object
mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
- struct Lisp_Vector *ptr = XVECTOR (obj);
+ Lisp_Vector *ptr = XVECTOR (obj);
int len = vector_length (ptr);
int i;
for (i = 0; i < len - 1; i++)
- (markobj) (ptr->contents[i]);
+ markobj (ptr->contents[i]);
return (len > 0) ? ptr->contents[len - 1] : Qnil;
}
static size_t
size_vector (CONST void *lheader)
{
- /* * -1 because struct Lisp_Vector includes 1 slot */
- return sizeof (struct Lisp_Vector) +
- ((((struct Lisp_Vector *) lheader)->size - 1) * sizeof (Lisp_Object));
+ return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]);
}
static int
-vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
int indice;
- int len = XVECTOR_LENGTH (o1);
- if (len != XVECTOR_LENGTH (o2))
+ int len = XVECTOR_LENGTH (obj1);
+ if (len != XVECTOR_LENGTH (obj2))
return 0;
for (indice = 0; indice < len; indice++)
{
- if (!internal_equal (XVECTOR_DATA (o1) [indice],
- XVECTOR_DATA (o2) [indice],
+ if (!internal_equal (XVECTOR_DATA (obj1) [indice],
+ XVECTOR_DATA (obj2) [indice],
depth + 1))
return 0;
}
* knows how to handle vectors.
*/
0,
- size_vector, struct Lisp_Vector);
+ size_vector, Lisp_Vector);
/* #### should allocate `small' vectors from a frob-block */
-static struct Lisp_Vector *
+static Lisp_Vector *
make_vector_internal (size_t sizei)
{
- size_t sizem = (sizeof (struct Lisp_Vector)
- /* -1 because struct Lisp_Vector includes 1 slot */
- + (sizei - 1) * sizeof (Lisp_Object));
- struct Lisp_Vector *p =
- (struct Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
+ /* no vector_next */
+ size_t sizem = offsetof (Lisp_Vector, contents[sizei]);
+ Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
p->size = sizei;
return p;
static Lisp_Object all_vectors;
/* #### should allocate `small' vectors from a frob-block */
-static struct Lisp_Vector *
+static Lisp_Vector *
make_vector_internal (size_t sizei)
{
- size_t sizem = (sizeof (struct Lisp_Vector)
- /* -1 because struct Lisp_Vector includes 1 slot,
- * +1 to account for vector_next */
- + (sizei - 1 + 1) * sizeof (Lisp_Object));
- struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem);
+ /* + 1 to account for vector_next */
+ size_t sizem = offsetof (Lisp_Vector, contents[sizei+1]);
+ Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
INCREMENT_CONS_COUNTER (sizem, "vector");
{
int elt;
Lisp_Object vector;
- struct Lisp_Vector *p;
+ Lisp_Vector *p;
if (length < 0)
length = XINT (wrong_type_argument (Qnatnump, make_int (length)));
{
Lisp_Object vector;
int elt;
- struct Lisp_Vector *p = make_vector_internal (nargs);
+ Lisp_Vector *p = make_vector_internal (nargs);
for (elt = 0; elt < nargs; elt++)
vector_data(p)[elt] = args[elt];
}
#endif /* unused */
-/**********************************************************************/
-/* Bit Vector allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Bit Vector allocation */
+/************************************************************************/
static Lisp_Object all_bit_vectors;
static struct Lisp_Bit_Vector *
make_bit_vector_internal (size_t sizei)
{
- size_t sizem = sizeof (struct Lisp_Bit_Vector) +
- /* -1 because struct Lisp_Bit_Vector includes 1 slot */
- sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1);
- struct Lisp_Bit_Vector *p =
- (struct Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
+ size_t sizem =
+ offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (sizei)]);
+ Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
set_lheader_implementation (&(p->lheader), lrecord_bit_vector);
INCREMENT_CONS_COUNTER (sizem, "bit-vector");
bit_vector_length (p) = sizei;
- bit_vector_next (p) = all_bit_vectors;
+ bit_vector_next (p) = all_bit_vectors;
/* make sure the extra bits in the last long are 0; the calling
functions might not set them. */
p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0;
}
\f
-/**********************************************************************/
-/* Compiled-function allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Compiled-function allocation */
+/************************************************************************/
-DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function);
+DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function);
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
static Lisp_Object
make_compiled_function (int make_pure)
{
- struct Lisp_Compiled_Function *b;
- Lisp_Object new;
- size_t size = sizeof (struct Lisp_Compiled_Function);
+ Lisp_Compiled_Function *f;
+ Lisp_Object fun;
+ size_t size = sizeof (Lisp_Compiled_Function);
if (make_pure && check_purespace (size))
{
- b = (struct Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
- set_lheader_implementation (&(b->lheader), lrecord_compiled_function);
+ f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
+ set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- b->lheader.pure = 1;
+ f->lheader.pure = 1;
#endif
pure_bytes_used += size;
- bump_purestat (&purestat_bytecode, size);
+ bump_purestat (&purestat_function, size);
}
else
{
- ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function,
- b);
- set_lheader_implementation (&(b->lheader), lrecord_compiled_function);
+ ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
+ set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
}
- b->maxdepth = 0;
- b->flags.documentationp = 0;
- b->flags.interactivep = 0;
- b->flags.domainp = 0; /* I18N3 */
- b->bytecodes = Qzero;
- b->constants = Qzero;
- b->arglist = Qnil;
- b->doc_and_interactive = Qnil;
+ f->stack_depth = 0;
+ f->specpdl_depth = 0;
+ f->flags.documentationp = 0;
+ f->flags.interactivep = 0;
+ f->flags.domainp = 0; /* I18N3 */
+ f->instructions = Qzero;
+ f->constants = Qzero;
+ f->arglist = Qnil;
+ f->doc_and_interactive = Qnil;
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- b->annotated = Qnil;
+ f->annotated = Qnil;
#endif
- XSETCOMPILED_FUNCTION (new, b);
- return new;
+ XSETCOMPILED_FUNCTION (fun, f);
+ return fun;
}
DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /*
Return a new compiled-function object.
-Usage: (arglist instructions constants stack-size
- &optional doc-string interactive-spec)
+Usage: (arglist instructions constants stack-depth
+ &optional doc-string interactive)
Note that, unlike all other emacs-lisp functions, calling this with five
arguments is NOT the same as calling it with six arguments, the last of
which is nil. If the INTERACTIVE arg is specified as nil, then that means
that this function was defined with `(interactive)'. If the arg is not
specified, then that means the function is not interactive.
This is terrible behavior which is retained for compatibility with old
-`.elc' files which expected these semantics.
+`.elc' files which expect these semantics.
*/
(int nargs, Lisp_Object *args))
{
-/* In a non-insane world this function would have this arglist...
- (arglist, instructions, constants, stack_size, doc_string, interactive)
- Lisp_Object arglist, instructions, constants, stack_size, doc_string,
- interactive;
+/* In a non-insane world this function would have this arglist...
+ (arglist instructions constants stack_depth &optional doc_string interactive)
*/
+ Lisp_Object fun = make_compiled_function (purify_flag);
+ Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
+
Lisp_Object arglist = args[0];
Lisp_Object instructions = args[1];
Lisp_Object constants = args[2];
- Lisp_Object stack_size = args[3];
+ Lisp_Object stack_depth = args[3];
Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
+
/* Don't purecopy the doc references in instructions because it's
wasteful; they will get fixed up later.
Note: there will be a window after the byte code is created and
before the doc references are fixed up in which there will be
impure objects inside a pure object, which apparently won't
- get marked, leading the trouble. But during that entire window,
+ get marked, leading to trouble. But during that entire window,
the objects are sitting on Vload_force_doc_string_list, which
is staticpro'd, so we're OK. */
- int purecopy_instructions = 1;
+ Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
+ = purify_flag ? pure_cons : Fcons;
- if (nargs > 6)
+ if (nargs < 4 || nargs > 6)
return Fsignal (Qwrong_number_of_arguments,
list2 (intern ("make-byte-code"), make_int (nargs)));
- CHECK_LIST (arglist);
- /* instructions is a string or a cons (string . int) for a
+ /* Check for valid formal parameter list now, to allow us to use
+ SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
+ {
+ Lisp_Object symbol, tail;
+ EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
+ {
+ CHECK_SYMBOL (symbol);
+ if (EQ (symbol, Qt) ||
+ EQ (symbol, Qnil) ||
+ SYMBOL_IS_KEYWORD (symbol))
+ signal_simple_error_2
+ ("Invalid constant symbol in formal parameter list",
+ symbol, arglist);
+ }
+ }
+ f->arglist = arglist;
+
+ /* `instructions' is a string or a cons (string . int) for a
lazy-loaded function. */
if (CONSP (instructions))
{
CHECK_STRING (XCAR (instructions));
CHECK_INT (XCDR (instructions));
- if (!NILP (constants))
- CHECK_VECTOR (constants);
- purecopy_instructions = 0;
}
else
{
CHECK_STRING (instructions);
- CHECK_VECTOR (constants);
}
- CHECK_NATNUM (stack_size);
- /* doc_string may be nil, string, int, or a cons (string . int). */
+ f->instructions = instructions;
- /* interactive may be list or string (or unbound). */
+ if (!NILP (constants))
+ CHECK_VECTOR (constants);
+ f->constants = constants;
- if (purify_flag)
+ CHECK_NATNUM (stack_depth);
+ f->stack_depth = XINT (stack_depth);
+
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ if (!NILP (Vcurrent_compiled_function_annotation))
+ f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
+ else if (!NILP (Vload_file_name_internal_the_purecopy))
+ f->annotated = Vload_file_name_internal_the_purecopy;
+ else if (!NILP (Vload_file_name_internal))
{
- if (!purified (arglist))
- arglist = Fpurecopy (arglist);
- if (purecopy_instructions && !purified (instructions))
- instructions = Fpurecopy (instructions);
- if (!purified (doc_string))
- doc_string = Fpurecopy (doc_string);
- if (!purified (interactive) && !UNBOUNDP (interactive))
- interactive = Fpurecopy (interactive);
+ struct gcpro gcpro1;
+ GCPRO1 (fun); /* don't let fun get reaped */
+ Vload_file_name_internal_the_purecopy =
+ Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
+ f->annotated = Vload_file_name_internal_the_purecopy;
+ UNGCPRO;
+ }
+#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
- /* Statistics are kept differently for the constants */
- if (!purified (constants))
-#ifdef PURESTAT
+ /* doc_string may be nil, string, int, or a cons (string . int).
+ interactive may be list or string (or unbound). */
+ f->doc_and_interactive = Qunbound;
+#ifdef I18N3
+ if ((f->flags.domainp = !NILP (Vfile_domain)) != 0)
+ f->doc_and_interactive = Vfile_domain;
+#endif
+ if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
+ {
+ if (purify_flag)
{
- int old = purecopying_for_bytecode;
- purecopying_for_bytecode = 1;
- constants = Fpurecopy (constants);
- purecopying_for_bytecode = old;
+ interactive = Fpurecopy (interactive);
+ if (STRINGP (interactive))
+ bump_purestat (&purestat_string_interactive,
+ pure_sizeof (interactive));
}
-#else
- constants = Fpurecopy (constants);
-#endif /* PURESTAT */
+ f->doc_and_interactive
+ = (UNBOUNDP (f->doc_and_interactive) ? interactive :
+ cons (interactive, f->doc_and_interactive));
+ }
+ if ((f->flags.documentationp = !NILP (doc_string)) != 0)
+ {
+ if (purify_flag)
+ {
+ doc_string = Fpurecopy (doc_string);
+ if (STRINGP (doc_string))
+ /* These should have been snagged by make-docfile... */
+ bump_purestat (&purestat_string_documentation,
+ pure_sizeof (doc_string));
+ }
+ f->doc_and_interactive
+ = (UNBOUNDP (f->doc_and_interactive) ? doc_string :
+ cons (doc_string, f->doc_and_interactive));
+ }
+ if (UNBOUNDP (f->doc_and_interactive))
+ f->doc_and_interactive = Qnil;
+
+ if (purify_flag)
+ {
+
+ if (!purified (f->arglist))
+ f->arglist = Fpurecopy (f->arglist);
+ /* Statistics are kept differently for the constants */
+ if (!purified (f->constants))
+ {
#ifdef PURESTAT
- if (STRINGP (instructions))
- bump_purestat (&purestat_string_bytecodes, pure_sizeof (instructions));
- if (VECTORP (constants))
- bump_purestat (&purestat_vector_bytecode_constants,
- pure_sizeof (constants));
- if (STRINGP (doc_string))
- /* These should be have been snagged by make-docfile... */
- bump_purestat (&purestat_string_documentation,
- pure_sizeof (doc_string));
- if (STRINGP (interactive))
- bump_purestat (&purestat_string_interactive,
- pure_sizeof (interactive));
+ int old = purecopying_function_constants;
+ purecopying_function_constants = 1;
+ f->constants = Fpurecopy (f->constants);
+ bump_purestat (&purestat_vector_constants,
+ pure_sizeof (f->constants));
+ purecopying_function_constants = old;
+#else
+ f->constants = Fpurecopy (f->constants);
#endif /* PURESTAT */
- }
+ }
- {
- int docp = !NILP (doc_string);
- int intp = !UNBOUNDP (interactive);
-#ifdef I18N3
- int domp = !NILP (Vfile_domain);
-#endif
- Lisp_Object val = make_compiled_function (purify_flag);
- struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (val);
- b->flags.documentationp = docp;
- b->flags.interactivep = intp;
-#ifdef I18N3
- b->flags.domainp = domp;
-#endif
- b->maxdepth = XINT (stack_size);
- b->bytecodes = instructions;
- b->constants = constants;
- b->arglist = arglist;
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- if (!NILP (Vcurrent_compiled_function_annotation))
- b->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
- else if (!NILP (Vload_file_name_internal_the_purecopy))
- b->annotated = Vload_file_name_internal_the_purecopy;
- else if (!NILP (Vload_file_name_internal))
- {
- struct gcpro gcpro1;
- GCPRO1(val); /* don't let val or b get reaped */
- Vload_file_name_internal_the_purecopy =
- Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
- b->annotated = Vload_file_name_internal_the_purecopy;
- UNGCPRO;
- }
-#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
+ optimize_compiled_function (fun);
-#ifdef I18N3
- if (docp && intp && domp)
- b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
- (doc_string,
- (((purify_flag) ? pure_cons : Fcons)
- (interactive, Vfile_domain))));
- else if (docp && domp)
- b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
- (doc_string, Vfile_domain));
- else if (intp && domp)
- b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
- (interactive, Vfile_domain));
- else
-#endif
- if (docp && intp)
- b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
- (doc_string, interactive));
- else if (intp)
- b->doc_and_interactive = interactive;
-#ifdef I18N3
- else if (domp)
- b->doc_and_interactive = Vfile_domain;
-#endif
- else
- b->doc_and_interactive = doc_string;
+ bump_purestat (&purestat_opaque_instructions,
+ pure_sizeof (f->instructions));
+ }
- return val;
- }
+ return fun;
}
\f
-/**********************************************************************/
-/* Symbol allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Symbol allocation */
+/************************************************************************/
DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol);
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000
Return a newly allocated uninterned symbol whose name is NAME.
Its value and function definition are void, and its property list is nil.
*/
- (str))
+ (name))
{
Lisp_Object val;
struct Lisp_Symbol *p;
- CHECK_STRING (str);
+ CHECK_STRING (name);
ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
#ifdef LRECORD_SYMBOL
set_lheader_implementation (&(p->lheader), lrecord_symbol);
#endif
- p->name = XSTRING (str);
- p->plist = Qnil;
- p->value = Qunbound;
+ p->name = XSTRING (name);
+ p->plist = Qnil;
+ p->value = Qunbound;
p->function = Qunbound;
- p->obarray = Qnil;
+ p->obarray = Qnil;
symbol_next (p) = 0;
XSETSYMBOL (val, p);
return val;
}
\f
-/**********************************************************************/
-/* Extent allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Extent allocation */
+/************************************************************************/
DECLARE_FIXED_TYPE_ALLOC (extent, struct extent);
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000
struct extent *e;
ALLOCATE_FIXED_TYPE (extent, struct extent, e);
- /* xzero (*e); */
set_lheader_implementation (&(e->lheader), lrecord_extent);
extent_object (e) = Qnil;
set_extent_start (e, -1);
}
\f
-/**********************************************************************/
-/* Event allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Event allocation */
+/************************************************************************/
DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event);
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000
}
\f
-/**********************************************************************/
-/* Marker allocation */
-/**********************************************************************/
+/************************************************************************/
+/* Marker allocation */
+/************************************************************************/
DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker);
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000
}
\f
-/**********************************************************************/
-/* String allocation */
-/**********************************************************************/
+/************************************************************************/
+/* String allocation */
+/************************************************************************/
/* The data for "short" strings generally resides inside of structs of type
string_chars_block. The Lisp_String structure is allocated just like any
}
static int
-string_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
Bytecount len;
- return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
- !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
+ return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
+ !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
}
DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
*/
(length, init))
{
- Lisp_Object val;
-
CHECK_NATNUM (length);
CHECK_CHAR_COERCE_INT (init);
{
- Bufbyte str[MAX_EMCHAR_LEN];
- int len = set_charptr_emchar (str, XCHAR (init));
+ Bufbyte init_str[MAX_EMCHAR_LEN];
+ int len = set_charptr_emchar (init_str, XCHAR (init));
+ Lisp_Object val = make_uninit_string (len * XINT (length));
- val = make_uninit_string (len * XINT (length));
if (len == 1)
/* Optimize the single-byte case */
memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
else
{
- int i, j, k;
+ int i;
Bufbyte *ptr = XSTRING_DATA (val);
- k = 0;
- for (i = 0; i < XINT (length); i++)
- for (j = 0; j < len; j++)
- ptr[k++] = str[j];
+ for (i = XINT (length); i; i--)
+ {
+ Bufbyte *init_ptr = init_str;
+ switch (len)
+ {
+ case 4: *ptr++ = *init_ptr++;
+ case 3: *ptr++ = *init_ptr++;
+ case 2: *ptr++ = *init_ptr++;
+ case 1: *ptr++ = *init_ptr++;
+ }
+ }
}
+ return val;
}
- return val;
}
DEFUN ("string", Fstring, 0, MANY, 0, /*
/* Make sure the size is correct. This will catch, for example,
putting a window configuration on the wrong free list. */
if (implementation->size_in_bytes_method)
- assert (((implementation->size_in_bytes_method) (lheader))
- == list->size);
+ assert (implementation->size_in_bytes_method (lheader) == list->size);
else
assert (implementation->static_size == list->size);
#endif /* ERROR_CHECK_GC */
if (implementation->finalizer)
- ((implementation->finalizer) (lheader, 0));
+ implementation->finalizer (lheader, 0);
free_header->chain = list->free;
free_header->lcheader.free = 1;
list->free = lcrecord;
}
\f
-/**********************************************************************/
-/* Purity of essence, peace on earth */
-/**********************************************************************/
+/************************************************************************/
+/* Purity of essence, peace on earth */
+/************************************************************************/
static int symbols_initialized;
#ifdef PURESTAT
bump_purestat (&purestat_string_all, size);
- if (purecopying_for_bytecode)
+ if (purecopying_function_constants)
bump_purestat (&purestat_string_other_function, size);
#endif /* PURESTAT */
make_pure_vector (size_t len, Lisp_Object init)
{
Lisp_Object new;
- struct Lisp_Vector *v;
- size_t size = (sizeof (struct Lisp_Vector)
- + (len - 1) * sizeof (Lisp_Object));
+ Lisp_Vector *v;
+ size_t size = offsetof (Lisp_Vector, contents[len]);
init = Fpurecopy (init);
if (!check_purespace (size))
return make_vector (len, init);
- v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used);
+ v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
#ifdef LRECORD_VECTOR
set_lheader_implementation (&(v->header.lheader), lrecord_vector);
#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
*/
(obj))
{
- int i;
if (!purify_flag)
- return obj;
-
- if (!POINTER_TYPE_P (XTYPE (obj))
- || PURIFIED (XPNTR (obj))
- /* happens when bootstrapping Qnil */
- || EQ (obj, Qnull_pointer))
- return obj;
-
- switch (XTYPE (obj))
{
-#ifndef LRECORD_CONS
- case Lisp_Type_Cons:
+ return obj;
+ }
+ else if (!POINTER_TYPE_P (XTYPE (obj))
+ || PURIFIED (XPNTR (obj))
+ /* happens when bootstrapping Qnil */
+ || EQ (obj, Qnull_pointer))
+ {
+ return obj;
+ }
+ /* Order of subsequent tests determined via profiling. */
+ else if (SYMBOLP (obj))
+ {
+ /* Symbols can't be made pure (and thus read-only), because
+ assigning to their function, value or plist slots would
+ produced a SEGV in the dumped XEmacs. So we previously would
+ just return the symbol unchanged.
+
+ But purified aggregate objects like lists and vectors can
+ contain uninterned symbols. If there are no other non-pure
+ references to the symbol, then the symbol is not protected
+ from garbage collection because the collector does not mark
+ the contents of purified objects. So to protect the symbols,
+ an impure reference has to be kept for each uninterned symbol
+ that is referenced by a pure object. All such symbols are
+ stored in the hash table pointed to by
+ Vpure_uninterned_symbol_table, which is itself
+ staticpro'd. */
+ if (NILP (XSYMBOL (obj)->obarray))
+ Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
+ return obj;
+ }
+ else if (CONSP (obj))
+ {
return pure_cons (XCAR (obj), XCDR (obj));
-#endif
-
-#ifndef LRECORD_STRING
- case Lisp_Type_String:
+ }
+ else if (STRINGP (obj))
+ {
return make_pure_string (XSTRING_DATA (obj),
XSTRING_LENGTH (obj),
XSTRING (obj)->plist,
- 0);
-#endif /* ! LRECORD_STRING */
+ 0);
+ }
+ else if (VECTORP (obj))
+ {
+ int i;
+ Lisp_Vector *o = XVECTOR (obj);
+ Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
+ for (i = 0; i < vector_length (o); i++)
+ XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
+ return pure_obj;
+ }
+#ifdef LISP_FLOAT_TYPE
+ else if (FLOATP (obj))
+ {
+ return make_pure_float (XFLOAT_DATA (obj));
+ }
+#endif
+ else if (COMPILED_FUNCTIONP (obj))
+ {
+ Lisp_Object pure_obj = make_compiled_function (1);
+ Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
+ Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
+ n->flags = o->flags;
+ n->instructions = o->instructions;
+ n->constants = Fpurecopy (o->constants);
+ n->arglist = Fpurecopy (o->arglist);
+ n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
+ n->stack_depth = o->stack_depth;
+ optimize_compiled_function (pure_obj);
+ return pure_obj;
+ }
+ else if (OPAQUEP (obj))
+ {
+ Lisp_Object pure_obj;
+ Lisp_Opaque *old_opaque = XOPAQUE (obj);
+ Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
+ struct lrecord_header *lheader = XRECORD_LHEADER (obj);
+ CONST struct lrecord_implementation *implementation
+ = LHEADER_IMPLEMENTATION (lheader);
+ size_t size = implementation->size_in_bytes_method (lheader);
+ size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
+ if (!check_purespace (pure_size))
+ return obj;
+ pure_bytes_used += pure_size;
-#ifndef LRECORD_VECTOR
- case Lisp_Type_Vector:
- {
- struct Lisp_Vector *o = XVECTOR (obj);
- Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
- for (i = 0; i < vector_length (o); i++)
- XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
- return new;
- }
-#endif /* !LRECORD_VECTOR */
+ memcpy (new_opaque, old_opaque, size);
+#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
+ lheader->pure = 1;
+#endif
+ new_opaque->header.next = 0;
- default:
- {
- if (COMPILED_FUNCTIONP (obj))
- {
- struct Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
- Lisp_Object new = make_compiled_function (1);
- /* How on earth could this code have worked before? -sb */
- struct Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (new);
- n->flags = o->flags;
- n->bytecodes = Fpurecopy (o->bytecodes);
- n->constants = Fpurecopy (o->constants);
- n->arglist = Fpurecopy (o->arglist);
- n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
- n->maxdepth = o->maxdepth;
- return new;
- }
-#ifdef LRECORD_CONS
- else if (CONSP (obj))
- return pure_cons (XCAR (obj), XCDR (obj));
-#endif /* LRECORD_CONS */
-#ifdef LRECORD_VECTOR
- else if (VECTORP (obj))
- {
- struct Lisp_Vector *o = XVECTOR (obj);
- Lisp_Object new = make_pure_vector (vector_length (o), Qnil);
- for (i = 0; i < vector_length (o); i++)
- XVECTOR_DATA (new)[i] = Fpurecopy (o->contents[i]);
- return new;
- }
-#endif /* LRECORD_VECTOR */
-#ifdef LRECORD_STRING
- else if (STRINGP (obj))
- {
- return make_pure_string (XSTRING_DATA (obj),
- XSTRING_LENGTH (obj),
- XSTRING (obj)->plist,
- 0);
- }
-#endif /* LRECORD_STRING */
-#ifdef LISP_FLOAT_TYPE
- else if (FLOATP (obj))
- return make_pure_float (float_data (XFLOAT (obj)));
-#endif /* LISP_FLOAT_TYPE */
- else if (SYMBOLP (obj))
- {
- /*
- * Symbols can't be made pure (and thus read-only),
- * because assigning to their function, value or plist
- * slots would produced a SEGV in the dumped XEmacs. So
- * we previously would just return the symbol unchanged.
- *
- * But purified aggregate objects like lists and vectors
- * can contain uninterned symbols. If there are no
- * other non-pure references to the symbol, then the
- * symbol is not protected from garbage collection
- * because the collector does not mark the contents of
- * purified objects. So to protect the symbols, an impure
- * reference has to be kept for each uninterned symbol
- * that is referenced by a pure object. All such
- * symbols are stored in the hashtable pointed to by
- * Vpure_uninterned_symbol_table, which is itself
- * staticpro'd.
- */
- if (!NILP (XSYMBOL (obj)->obarray))
- return obj;
- Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
- return obj;
- }
- else
- signal_simple_error ("Can't purecopy %S", obj);
- }
+ XSETOPAQUE (pure_obj, new_opaque);
+ return pure_obj;
}
- return obj;
+ else
+ {
+ signal_simple_error ("Can't purecopy %S", obj);
+ }
+ return obj; /* Unreached */
}
purestat_vector_other.nbytes =
purestat_vector_all.nbytes -
- purestat_vector_bytecode_constants.nbytes;
+ purestat_vector_constants.nbytes;
purestat_vector_other.nobjects =
purestat_vector_all.nobjects -
- purestat_vector_bytecode_constants.nobjects;
+ purestat_vector_constants.nobjects;
purestat_string_other.nbytes =
purestat_string_all.nbytes -
(purestat_string_pname.nbytes +
- purestat_string_bytecodes.nbytes +
purestat_string_interactive.nbytes +
purestat_string_documentation.nbytes +
#ifdef I18N3
purestat_string_other.nobjects =
purestat_string_all.nobjects -
(purestat_string_pname.nobjects +
- purestat_string_bytecodes.nobjects +
purestat_string_interactive.nobjects +
purestat_string_documentation.nobjects +
#ifdef I18N3
#endif
purestat_string_other_function.nobjects);
- message (" %-26s Total Bytes", "");
+ message (" %-34s Objects Bytes", "");
- {
- int j;
+ print_purestat (&purestat_cons);
+ print_purestat (&purestat_float);
+ print_purestat (&purestat_string_pname);
+ print_purestat (&purestat_function);
+ print_purestat (&purestat_opaque_instructions);
+ print_purestat (&purestat_vector_constants);
+ print_purestat (&purestat_string_interactive);
+#ifdef I18N3
+ print_purestat (&purestat_string_domain);
+#endif
+ print_purestat (&purestat_string_documentation);
+ print_purestat (&purestat_string_other_function);
+ print_purestat (&purestat_vector_other);
+ print_purestat (&purestat_string_other);
+ print_purestat (&purestat_string_all);
+ print_purestat (&purestat_vector_all);
- for (j = 0; j < countof (purestats); j++)
- if (!purestats[j])
- clear_message ();
- else
- {
- char buf [100];
- sprintf(buf, "%s:", purestats[j]->name);
- message (" %-26s %5d %7d %2d%%",
- buf,
- purestats[j]->nobjects,
- purestats[j]->nbytes,
- (int) (purestats[j]->nbytes / (pure_bytes_used / 100.0) + 0.5));
- }
- }
#endif /* PURESTAT */
if (report_impurities)
{
- Lisp_Object tem = Felt (Fgarbage_collect (), make_int (5));
+ Lisp_Object plist;
struct gcpro gcpro1;
- GCPRO1 (tem);
+ plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
+ GCPRO1 (plist);
message ("\nImpurities:");
- while (!NILP (tem))
+ for (; CONSP (plist); plist = XCDR (XCDR (plist)))
{
- if (CONSP (tem) && SYMBOLP (Fcar (tem)) && CONSP (Fcdr (tem)))
- {
- int total = XINT (Fcar (Fcdr (tem)));
- if (total > 0)
- {
- char buf [100];
- char *s = buf;
- memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name),
- string_length (XSYMBOL (Fcar (tem))->name) + 1);
- while (*s++) if (*s == '-') *s = ' ';
- s--; *s++ = ':'; *s = 0;
- message (" %-33s %6d", buf, total);
- }
- tem = Fcdr (Fcdr (tem));
- }
- else /* WTF?! */
+ Lisp_Object symbol = XCAR (plist);
+ int size = XINT (XCAR (XCDR (plist)));
+ if (size > 0)
{
- Fprin1 (tem, Qexternal_debugging_output);
- tem = Qnil;
+ char buf [100];
+ char *s = buf;
+ memcpy (buf,
+ string_data (XSYMBOL (symbol)->name),
+ string_length (XSYMBOL (symbol)->name) + 1);
+ while (*s++) if (*s == '-') *s = ' ';
+ *(s-1) = ':'; *s = 0;
+ message (" %-34s %6d", buf, size);
}
}
UNGCPRO;
- garbage_collect_1 (); /* GC garbage_collect's garbage */
+ garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */
}
clear_message ();
}
\f
-/**********************************************************************/
-/* staticpro */
-/**********************************************************************/
+/************************************************************************/
+/* Garbage Collection */
+/************************************************************************/
+
+/* This will be used more extensively In The Future */
+static int last_lrecord_type_index_assigned;
+
+CONST struct lrecord_implementation *lrecord_implementations_table[128];
+#define max_lrecord_type (countof (lrecord_implementations_table) - 1)
struct gcpro *gcprolist;
{
tail_recurse:
- if (EQ (obj, Qnull_pointer))
- return;
- if (!POINTER_TYPE_P (XGCTYPE (obj)))
- return;
- if (PURIFIED (XPNTR (obj)))
- return;
+#ifdef ERROR_CHECK_GC
+ assert (! (GC_EQ (obj, Qnull_pointer)));
+#endif
+ /* Checks we used to perform */
+ /* if (EQ (obj, Qnull_pointer)) return; */
+ /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
+ /* if (PURIFIED (XPNTR (obj))) return; */
+
switch (XGCTYPE (obj))
{
#ifndef LRECORD_CONS
case Lisp_Type_Cons:
{
struct Lisp_Cons *ptr = XCONS (obj);
+ if (PURIFIED (ptr))
+ break;
if (CONS_MARKED_P (ptr))
break;
MARK_CONS (ptr);
/* If the cdr is nil, tail-recurse on the car. */
- if (NILP (ptr->cdr))
+ if (GC_NILP (ptr->cdr))
{
obj = ptr->car;
}
#endif
case Lisp_Type_Record:
- /* case Lisp_Symbol_Value_Magic: */
{
struct lrecord_header *lheader = XRECORD_LHEADER (obj);
- CONST struct lrecord_implementation *implementation
- = LHEADER_IMPLEMENTATION (lheader);
+#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
+ assert (lheader->type <= last_lrecord_type_index_assigned);
+#endif
+ if (PURIFIED (lheader))
+ return;
if (! MARKED_RECORD_HEADER_P (lheader) &&
! UNMARKABLE_RECORD_HEADER_P (lheader))
{
+ CONST struct lrecord_implementation *implementation =
+ LHEADER_IMPLEMENTATION (lheader);
MARK_RECORD_HEADER (lheader);
#ifdef ERROR_CHECK_GC
if (!implementation->basic_p)
assert (! ((struct lcrecord_header *) lheader)->free);
#endif
- if (implementation->marker != 0)
+ if (implementation->marker)
{
- obj = ((implementation->marker) (obj, mark_object));
- if (!NILP (obj)) goto tail_recurse;
+ obj = implementation->marker (obj, mark_object);
+ if (!GC_NILP (obj)) goto tail_recurse;
}
}
}
case Lisp_Type_String:
{
struct Lisp_String *ptr = XSTRING (obj);
+ if (PURIFIED (ptr))
+ return;
if (!XMARKBIT (ptr->plist))
{
case Lisp_Type_Vector:
{
struct Lisp_Vector *ptr = XVECTOR (obj);
- int len = vector_length (ptr);
- int i;
+ int len, i;
+
+ if (PURIFIED (ptr))
+ return;
+
+ len = vector_length (ptr);
if (len < 0)
break; /* Already marked */
{
struct Lisp_Symbol *sym = XSYMBOL (obj);
+ if (PURIFIED (sym))
+ return;
+
while (!XMARKBIT (sym->plist))
{
XMARK (sym->plist);
* Lisp_Object. Fix it up and pass to mark_object.
*/
Lisp_Object symname;
- XSETSTRING(symname, sym->name);
- mark_object(symname);
+ XSETSTRING (symname, sym->name);
+ mark_object (symname);
}
if (!symbol_next (sym))
{
break;
#endif /* !LRECORD_SYMBOL */
+ /* Check for invalid Lisp_Object types */
+#if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
+ case Lisp_Type_Int:
+ case Lisp_Type_Char:
+ break;
default:
- abort ();
+ abort();
+ break;
+#endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
}
}
/* Simpler than mark-object, because pure structure can't
have any circularities */
-#if 0 /* unused */
-static int idiot_c_doesnt_have_closures;
-static void
-idiot_c (Lisp_Object obj)
-{
- idiot_c_doesnt_have_closures += pure_sizeof (obj, 1);
-}
-#endif /* unused */
-
static size_t
pure_string_sizeof (Lisp_Object obj)
{
}
}
-/* recurse arg isn't actually used */
static size_t
-pure_sizeof (Lisp_Object obj /*, int recurse */)
+pure_sizeof (Lisp_Object obj)
{
- size_t total = 0;
-
- /*tail_recurse: */
if (!POINTER_TYPE_P (XTYPE (obj))
|| !PURIFIED (XPNTR (obj)))
- return total;
-
- /* symbol's sizes are accounted for separately */
- if (SYMBOLP (obj))
- return total;
-
- switch (XTYPE (obj))
+ return 0;
+ /* symbol sizes are accounted for separately */
+ else if (SYMBOLP (obj))
+ return 0;
+ else if (STRINGP (obj))
+ return pure_string_sizeof (obj);
+ else if (LRECORDP (obj))
{
+ struct lrecord_header *lheader = XRECORD_LHEADER (obj);
+ CONST struct lrecord_implementation *implementation
+ = LHEADER_IMPLEMENTATION (lheader);
-#ifndef LRECORD_STRING
- case Lisp_Type_String:
- total += pure_string_sizeof (obj);
- break;
-#endif /* ! LRECORD_STRING */
-
+ return implementation->size_in_bytes_method
+ ? implementation->size_in_bytes_method (lheader)
+ : implementation->static_size;
+ }
#ifndef LRECORD_VECTOR
- case Lisp_Type_Vector:
- {
- struct Lisp_Vector *ptr = XVECTOR (obj);
- int len = vector_length (ptr);
-
- total += (sizeof (struct Lisp_Vector)
- + (len - 1) * sizeof (Lisp_Object));
-#if 0 /* unused */
- if (!recurse)
- break;
- {
- int i;
- for (i = 0; i < len - 1; i++)
- total += pure_sizeof (ptr->contents[i], 1);
- }
- if (len > 0)
- {
- obj = ptr->contents[len - 1];
- goto tail_recurse;
- }
-#endif /* unused */
- }
- break;
+ else if (VECTORP (obj))
+ return offsetof (Lisp_Vector, contents[XVECTOR_LENGTH (obj)]);
#endif /* !LRECORD_VECTOR */
- case Lisp_Type_Record:
- {
- struct lrecord_header *lheader = XRECORD_LHEADER (obj);
- CONST struct lrecord_implementation *implementation
- = LHEADER_IMPLEMENTATION (lheader);
-
-#ifdef LRECORD_STRING
- if (STRINGP (obj))
- total += pure_string_sizeof (obj);
- else
-#endif
- if (implementation->size_in_bytes_method)
- total += ((implementation->size_in_bytes_method) (lheader));
- else
- total += implementation->static_size;
-
-#if 0 /* unused */
- if (!recurse)
- break;
-
- if (implementation->marker != 0)
- {
- int old = idiot_c_doesnt_have_closures;
-
- idiot_c_doesnt_have_closures = 0;
- obj = ((implementation->marker) (obj, idiot_c));
- total += idiot_c_doesnt_have_closures;
- idiot_c_doesnt_have_closures = old;
-
- if (!NILP (obj)) goto tail_recurse;
- }
-#endif /* unused */
- }
- break;
-
#ifndef LRECORD_CONS
- case Lisp_Type_Cons:
- {
- struct Lisp_Cons *ptr = XCONS (obj);
- total += sizeof (*ptr);
-#if 0 /* unused */
- if (!recurse)
- break;
- /* If the cdr is nil, tail-recurse on the car. */
- if (NILP (ptr->cdr))
- {
- obj = ptr->car;
- }
- else
- {
- total += pure_sizeof (ptr->car, 1);
- obj = ptr->cdr;
- }
- goto tail_recurse;
-#endif /* unused */
- }
- break;
-#endif
-
- /* Others can't be purified */
- default:
- abort ();
- }
- return total;
+ else if (CONSP (obj))
+ return sizeof (struct Lisp_Cons);
+#endif /* !LRECORD_CONS */
+ else
+ /* Others can't be purified */
+ abort ();
+ return 0; /* unreached */
}
#endif /* PURESTAT */
/* static int gc_count_total_records_used, gc_count_records_total_size; */
\f
-/* This will be used more extensively In The Future */
-static int last_lrecord_type_index_assigned;
-
-CONST struct lrecord_implementation *lrecord_implementations_table[128];
-#define max_lrecord_type (countof (lrecord_implementations_table) - 1)
-
int
lrecord_type_index (CONST struct lrecord_implementation *implementation)
{
else
{
size_t sz = (implementation->size_in_bytes_method
- ? ((implementation->size_in_bytes_method) (h))
+ ? implementation->size_in_bytes_method (h)
: implementation->static_size);
if (free_p)
if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
{
if (LHEADER_IMPLEMENTATION (h)->finalizer)
- ((LHEADER_IMPLEMENTATION (h)->finalizer) (h, 0));
+ LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
}
}
{
UNMARK_RECORD_HEADER (h);
num_used++;
- /* total_size += ((n->implementation->size_in_bytes) (h));*/
+ /* total_size += n->implementation->size_in_bytes (h);*/
prev = &(header->next);
header = *prev;
tick_lcrecord_stats (h, 0);
for (vector = *prev; VECTORP (vector); )
{
- struct Lisp_Vector *v = XVECTOR (vector);
+ Lisp_Vector *v = XVECTOR (vector);
int len = v->size;
if (len < 0) /* marked */
{
len = - (len + 1);
v->size = len;
total_size += len;
- total_storage += (MALLOC_OVERHEAD
- + sizeof (struct Lisp_Vector)
- + (len - 1 + 1) * sizeof (Lisp_Object));
+ total_storage +=
+ MALLOC_OVERHEAD + offsetof (Lisp_Vector, contents[len + 1]);
num_used++;
prev = &(vector_next (v));
vector = *prev;
their implementation */
for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
int len = v->size;
if (MARKED_RECORD_P (bit_vector))
{
UNMARK_RECORD_HEADER (&(v->lheader));
total_size += len;
- total_storage += (MALLOC_OVERHEAD
- + sizeof (struct Lisp_Bit_Vector)
- + (BIT_VECTOR_LONG_STORAGE (len) - 1)
- * sizeof (long));
+ total_storage +=
+ MALLOC_OVERHEAD
+ + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]);
num_used++;
prev = &(bit_vector_next (v));
bit_vector = *prev;
#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
do { \
- struct typename##_block *_frob_current; \
- struct typename##_block **_frob_prev; \
- int _frob_limit; \
+ struct typename##_block *SFTB_current; \
+ struct typename##_block **SFTB_prev; \
+ int SFTB_limit; \
int num_free = 0, num_used = 0; \
\
- for (_frob_prev = ¤t_##typename##_block, \
- _frob_current = current_##typename##_block, \
- _frob_limit = current_##typename##_block_index; \
- _frob_current; \
+ for (SFTB_prev = ¤t_##typename##_block, \
+ SFTB_current = current_##typename##_block, \
+ SFTB_limit = current_##typename##_block_index; \
+ SFTB_current; \
) \
{ \
- int _frob_iii; \
+ int SFTB_iii; \
\
- for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \
+ for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
{ \
- obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \
+ obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
\
- if (FREE_STRUCT_P (_frob_victim)) \
+ if (FREE_STRUCT_P (SFTB_victim)) \
{ \
num_free++; \
} \
- else if (!MARKED_##typename##_P (_frob_victim)) \
+ else if (!MARKED_##typename##_P (SFTB_victim)) \
{ \
num_free++; \
- FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \
+ FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
} \
else \
{ \
num_used++; \
- UNMARK_##typename (_frob_victim); \
+ UNMARK_##typename (SFTB_victim); \
} \
} \
- _frob_prev = &(_frob_current->prev); \
- _frob_current = _frob_current->prev; \
- _frob_limit = countof (current_##typename##_block->block); \
+ SFTB_prev = &(SFTB_current->prev); \
+ SFTB_current = SFTB_current->prev; \
+ SFTB_limit = countof (current_##typename##_block->block); \
} \
\
gc_count_num_##typename##_in_use = num_used; \
#else /* !ERROR_CHECK_GC */
-#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
-do { \
- struct typename##_block *_frob_current; \
- struct typename##_block **_frob_prev; \
- int _frob_limit; \
- int num_free = 0, num_used = 0; \
- \
- typename##_free_list = 0; \
- \
- for (_frob_prev = ¤t_##typename##_block, \
- _frob_current = current_##typename##_block, \
- _frob_limit = current_##typename##_block_index; \
- _frob_current; \
- ) \
- { \
- int _frob_iii; \
- int _frob_empty = 1; \
- obj_type *_frob_old_free_list = typename##_free_list; \
- \
- for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \
- { \
- obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \
- \
- if (FREE_STRUCT_P (_frob_victim)) \
- { \
- num_free++; \
- PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, _frob_victim); \
- } \
- else if (!MARKED_##typename##_P (_frob_victim)) \
- { \
- num_free++; \
- FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \
- } \
- else \
- { \
- _frob_empty = 0; \
- num_used++; \
- UNMARK_##typename (_frob_victim); \
- } \
- } \
- if (!_frob_empty) \
- { \
- _frob_prev = &(_frob_current->prev); \
- _frob_current = _frob_current->prev; \
- } \
- else if (_frob_current == current_##typename##_block \
- && !_frob_current->prev) \
- { \
- /* No real point in freeing sole allocation block */ \
- break; \
- } \
- else \
- { \
- struct typename##_block *_frob_victim_block = _frob_current; \
- if (_frob_victim_block == current_##typename##_block) \
- current_##typename##_block_index \
- = countof (current_##typename##_block->block); \
- _frob_current = _frob_current->prev; \
- { \
- *_frob_prev = _frob_current; \
- xfree (_frob_victim_block); \
- /* Restore free list to what it was before victim was swept */ \
- typename##_free_list = _frob_old_free_list; \
- num_free -= _frob_limit; \
- } \
- } \
- _frob_limit = countof (current_##typename##_block->block); \
- } \
- \
- gc_count_num_##typename##_in_use = num_used; \
- gc_count_num_##typename##_freelist = num_free; \
+#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
+do { \
+ struct typename##_block *SFTB_current; \
+ struct typename##_block **SFTB_prev; \
+ int SFTB_limit; \
+ int num_free = 0, num_used = 0; \
+ \
+ typename##_free_list = 0; \
+ \
+ for (SFTB_prev = ¤t_##typename##_block, \
+ SFTB_current = current_##typename##_block, \
+ SFTB_limit = current_##typename##_block_index; \
+ SFTB_current; \
+ ) \
+ { \
+ int SFTB_iii; \
+ int SFTB_empty = 1; \
+ obj_type *SFTB_old_free_list = typename##_free_list; \
+ \
+ for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
+ { \
+ obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
+ \
+ if (FREE_STRUCT_P (SFTB_victim)) \
+ { \
+ num_free++; \
+ PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
+ } \
+ else if (!MARKED_##typename##_P (SFTB_victim)) \
+ { \
+ num_free++; \
+ FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
+ } \
+ else \
+ { \
+ SFTB_empty = 0; \
+ num_used++; \
+ UNMARK_##typename (SFTB_victim); \
+ } \
+ } \
+ if (!SFTB_empty) \
+ { \
+ SFTB_prev = &(SFTB_current->prev); \
+ SFTB_current = SFTB_current->prev; \
+ } \
+ else if (SFTB_current == current_##typename##_block \
+ && !SFTB_current->prev) \
+ { \
+ /* No real point in freeing sole allocation block */ \
+ break; \
+ } \
+ else \
+ { \
+ struct typename##_block *SFTB_victim_block = SFTB_current; \
+ if (SFTB_victim_block == current_##typename##_block) \
+ current_##typename##_block_index \
+ = countof (current_##typename##_block->block); \
+ SFTB_current = SFTB_current->prev; \
+ { \
+ *SFTB_prev = SFTB_current; \
+ xfree (SFTB_victim_block); \
+ /* Restore free list to what it was before victim was swept */ \
+ typename##_free_list = SFTB_old_free_list; \
+ num_free -= SFTB_limit; \
+ } \
+ } \
+ SFTB_limit = countof (current_##typename##_block->block); \
+ } \
+ \
+ gc_count_num_##typename##_in_use = num_used; \
+ gc_count_num_##typename##_freelist = num_free; \
} while (0)
#endif /* !ERROR_CHECK_GC */
#define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
#define ADDITIONAL_FREE_compiled_function(ptr)
- SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function);
+ SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
}
static int
marked_p (Lisp_Object obj)
{
- if (EQ (obj, Qnull_pointer)) return 1;
- if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1;
- if (PURIFIED (XPNTR (obj))) return 1;
+#ifdef ERROR_CHECK_GC
+ assert (! (GC_EQ (obj, Qnull_pointer)));
+#endif
+ /* Checks we used to perform. */
+ /* if (EQ (obj, Qnull_pointer)) return 1; */
+ /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
+ /* if (PURIFIED (XPNTR (obj))) return 1; */
+
switch (XGCTYPE (obj))
{
#ifndef LRECORD_CONS
case Lisp_Type_Cons:
- return XMARKBIT (XCAR (obj));
+ {
+ struct Lisp_Cons *ptr = XCONS (obj);
+ return PURIFIED (ptr) || XMARKBIT (ptr->car);
+ }
#endif
case Lisp_Type_Record:
- return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj));
+ {
+ struct lrecord_header *lheader = XRECORD_LHEADER (obj);
+#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
+ assert (lheader->type <= last_lrecord_type_index_assigned);
+#endif
+ return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader);
+ }
#ifndef LRECORD_STRING
case Lisp_Type_String:
- return XMARKBIT (XSTRING (obj)->plist);
+ {
+ struct Lisp_String *ptr = XSTRING (obj);
+ return PURIFIED (ptr) || XMARKBIT (ptr->plist);
+ }
#endif /* ! LRECORD_STRING */
#ifndef LRECORD_VECTOR
case Lisp_Type_Vector:
- return XVECTOR_LENGTH (obj) < 0;
+ {
+ struct Lisp_Vector *ptr = XVECTOR (obj);
+ return PURIFIED (ptr) || vector_length (ptr) < 0;
+ }
#endif /* !LRECORD_VECTOR */
#ifndef LRECORD_SYMBOL
case Lisp_Type_Symbol:
- return XMARKBIT (XSYMBOL (obj)->plist);
+ {
+ struct Lisp_Symbol *ptr = XSYMBOL (obj);
+ return PURIFIED (ptr) || XMARKBIT (ptr->plist);
+ }
#endif
+
+ /* Ints and Chars don't need GC */
+#if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC)
default:
- abort ();
+ return 1;
+#else
+ default:
+ abort();
+ case Lisp_Type_Int:
+ case Lisp_Type_Char:
+ return 1;
+#endif
}
- return 0; /* suppress compiler warning */
}
static void
{
/* It's important that certain information from the environment not get
dumped with the executable (pathnames, environment variables, etc.).
- To make it easier to tell when this has happend with strings(1) we
+ To make it easier to tell when this has happened with strings(1) we
clear some known-to-be-garbage blocks of memory, so that leftover
results of old evaluation don't look like potential problems.
But first we set some notable variables to nil and do one more GC,
void
garbage_collect_1 (void)
{
+#if MAX_SAVE_STACK > 0
char stack_top_variable;
extern char *stack_bottom;
+#endif
int i;
struct frame *f;
int speccount;
|| preparing_for_armageddon)
return;
+ /* We used to call selected_frame() here.
+
+ The following functions cannot be called inside GC
+ so we move to after the above tests. */
+ {
+ Lisp_Object frame;
+ Lisp_Object device = Fselected_device (Qnil);
+ if (NILP (device)) /* Could happen during startup, eg. if always_gc */
+ return;
+ frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
+ if (NILP (frame))
+ signal_simple_error ("No frames exist on device", device);
+ f = XFRAME (frame);
+ }
+
pre_gc_cursor = Qnil;
cursor_changed = 0;
- /* This function cannot be called inside GC so we move to after the */
- /* above tests */
- f = selected_frame ();
-
GCPRO1 (pre_gc_cursor);
/* Very important to prevent GC during any of the following
for (i = 0; i < staticidx; i++)
{
-#ifdef GDB_SUCKS
- printf ("%d\n", i);
- debug_print (*staticvec[i]);
-#endif
mark_object (*(staticvec[i]));
}
}
/* OK, now do the after-mark stuff. This is for things that
- are only marked when something else is marked (e.g. weak hashtables).
+ are only marked when something else is marked (e.g. weak hash tables).
There may be complex dependencies between such objects -- e.g.
- a weak hashtable might be unmarked, but after processing a later
- weak hashtable, the former one might get marked. So we have to
+ a weak hash table might be unmarked, but after processing a later
+ weak hash table, the former one might get marked. So we have to
iterate until nothing more gets marked. */
- {
- int did_mark;
- /* Need to iterate until there's nothing more to mark, in case
- of chains of mark dependencies. */
- do
- {
- did_mark = 0;
- did_mark += !!finish_marking_weak_hashtables (marked_p, mark_object);
- did_mark += !!finish_marking_weak_lists (marked_p, mark_object);
- }
- while (did_mark);
- }
+
+ while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
+ finish_marking_weak_lists (marked_p, mark_object) > 0)
+ ;
/* And prune (this needs to be called after everything else has been
marked and before we do any sweeping). */
/* #### this is somewhat ad-hoc and should probably be an object
method */
- prune_weak_hashtables (marked_p);
+ prune_weak_hash_tables (marked_p);
prune_weak_lists (marked_p);
prune_specifiers (marked_p);
prune_syntax_tables (marked_p);
return;
}
-#ifdef EMACS_BTL
- /* This isn't actually called. BTL recognizes the stack frame of the top
- of the garbage collector by noting that PC is between &garbage_collect_1
- and &BTL_after_garbage_collect_1_stub. So this fn must be right here.
- There's not any other way to know the address of the end of a function.
- */
-void BTL_after_garbage_collect_1_stub () { abort (); }
-#endif /* EMACS_BTL */
-
/* Debugging aids. */
static Lisp_Object
return cons3 (intern (name), make_int (value), tail);
}
-#define HACK_O_MATIC(type, name, pl) \
- { \
- int s = 0; \
- struct type##_block *x = current_##type##_block; \
- while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
- (pl) = gc_plist_hack ((name), s, (pl)); \
- }
+#define HACK_O_MATIC(type, name, pl) do { \
+ int s = 0; \
+ struct type##_block *x = current_##type##_block; \
+ while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
+ (pl) = gc_plist_hack ((name), s, (pl)); \
+} while (0)
DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
Reclaim storage for Lisp objects no longer needed.
{
int iii;
-#ifdef PURESTAT
- for (iii = 0; iii < countof (purestats); iii++)
- {
- if (! purestats[iii]) continue;
- purestats[iii]->nobjects = 0;
- purestats[iii]->nbytes = 0;
- }
- purecopying_for_bytecode = 0;
-#endif /* PURESTAT */
-
last_lrecord_type_index_assigned = -1;
for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
{
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);
#ifdef REGION_CACHE_NEEDS_WORK
#include "region-cache.h"
#endif
+#include "specifier.h"
#include "syntax.h"
#include "sysdep.h" /* for getwd */
#include "window.h"
undo_threshold,
undo_high_threshold);
-#define MARKED_SLOT(x) ((markobj) (buf->x));
+#define MARKED_SLOT(x) ((void) (markobj (buf->x)));
#include "bufslots.h"
#undef MARKED_SLOT
- ((markobj) (buf->extent_info));
+ markobj (buf->extent_info);
if (buf->text)
- ((markobj) (buf->text->line_number_cache));
+ markobj (buf->text->line_number_cache);
/* Don't mark normally through the children slot.
(Actually, in this case, it doesn't matter.) */
*/
(frame))
{
- Lisp_Object list;
- if (EQ (frame, Qt))
- list = Vbuffer_alist;
- else
- list = decode_frame (frame)->buffer_alist;
- return Fmapcar (Qcdr, list);
+ return Fmapcar (Qcdr,
+ EQ (frame, Qt) ? Vbuffer_alist :
+ decode_frame (frame)->buffer_alist);
}
Lisp_Object
(filename))
{
/* This function can GC. GC checked 1997.04.06. */
- REGISTER Lisp_Object tail, buf, tem;
+ REGISTER Lisp_Object buf;
struct gcpro gcpro1;
#ifdef I18N3
NUNGCPRO;
}
- LIST_LOOP (tail, Vbuffer_alist)
- {
- buf = Fcdr (XCAR (tail));
- if (!BUFFERP (buf)) continue;
- if (!STRINGP (XBUFFER (buf)->filename)) continue;
- tem = Fstring_equal (filename,
- (find_file_compare_truenames
- ? XBUFFER (buf)->file_truename
- : XBUFFER (buf)->filename));
- if (!NILP (tem))
- return buf;
- }
+ {
+ Lisp_Object elt;
+ LIST_LOOP_2 (elt, Vbuffer_alist)
+ {
+ buf = Fcdr (elt);
+ if (!BUFFERP (buf)) continue;
+ if (!STRINGP (XBUFFER (buf)->filename)) continue;
+ if (!NILP (Fstring_equal (filename,
+ (find_file_compare_truenames
+ ? XBUFFER (buf)->file_truename
+ : XBUFFER (buf)->filename))))
+ return buf;
+ }
+ }
return Qnil;
}
init_buffer_markers (b);
b->generated_modeline_string = Fmake_string (make_int (84), make_int (' '));
- b->modeline_extent_table = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK,
- HASHTABLE_EQ);
+ b->modeline_extent_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK,
+ HASH_TABLE_EQ);
return buf;
}
delete_auto_save_files = 1;
}
-/* DOC is ignored because it is snagged and recorded externally
- * by make-docfile */
+/* The docstrings for DEFVAR_* are recorded externally by make-docfile. */
+
/* Renamed from DEFVAR_PER_BUFFER because FSFmacs D_P_B takes
- * a bogus extra arg, which confuses an otherwise identical make-docfile.c */
+ a bogus extra arg, which confuses an otherwise identical make-docfile.c */
+
/* Declaring this stuff as const produces 'Cannot reinitialize' messages
from SunPro C's fix-and-continue feature (a way neato feature that
makes debugging unbelievably more bearable) */
-#define DEFVAR_BUFFER_LOCAL(lname, field_name) do { \
-static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
- = { { { symbol_value_forward_lheader_initializer, \
- (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
- SYMVAL_CURRENT_BUFFER_FORWARD }, 0 }; \
- defvar_buffer_local ((lname), &I_hate_C); \
- } while (0)
-
-#define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) do { \
-static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
- = { { { symbol_value_forward_lheader_initializer, \
- (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
- SYMVAL_CURRENT_BUFFER_FORWARD }, magicfun }; \
- defvar_buffer_local ((lname), &I_hate_C); \
- } while (0)
-
-#define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) do { \
-static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
- = { { { symbol_value_forward_lheader_initializer, \
- (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
- SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, 0 }; \
- defvar_buffer_local ((lname), &I_hate_C); \
- } while (0)
-
-#define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) do{\
-static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
- = { { { symbol_value_forward_lheader_initializer, \
- (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
- SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, magicfun }; \
- defvar_buffer_local ((lname), &I_hate_C); \
- } while (0)
-
-static void
-defvar_buffer_local (CONST char *namestring,
- CONST struct symbol_value_forward *m)
-{
- int offset = ((char *)symbol_value_forward_forward (m)
- - (char *)&buffer_local_flags);
-
- defvar_mumble (namestring, m, sizeof (*m));
-
- *((Lisp_Object *)(offset + (char *)XBUFFER (Vbuffer_local_symbols)))
- = intern (namestring);
-}
-
-/* DOC is ignored because it is snagged and recorded externally
- * by make-docfile */
-#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) do { \
-static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
- = { { { symbol_value_forward_lheader_initializer, \
- (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
- SYMVAL_DEFAULT_BUFFER_FORWARD }, 0 }; \
- defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \
- } while (0)
-
-#define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) do { \
-static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
- = { { { symbol_value_forward_lheader_initializer, \
- (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
- SYMVAL_DEFAULT_BUFFER_FORWARD }, magicfun }; \
- defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \
- } while (0)
+#define DEFVAR_BUFFER_LOCAL_1(lname, field_name, forward_type, magicfun) do { \
+ static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \
+ = { { { symbol_value_forward_lheader_initializer, \
+ (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \
+ forward_type }, magicfun }; \
+ { \
+ int offset = ((char *)symbol_value_forward_forward (&I_hate_C) - \
+ (char *)&buffer_local_flags); \
+ defvar_magic (lname, &I_hate_C); \
+ \
+ *((Lisp_Object *)(offset + (char *)XBUFFER (Vbuffer_local_symbols))) \
+ = intern (lname); \
+ } \
+} while (0)
+
+#define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \
+ DEFVAR_BUFFER_LOCAL_1 (lname, field_name, \
+ SYMVAL_CURRENT_BUFFER_FORWARD, magicfun)
+#define DEFVAR_BUFFER_LOCAL(lname, field_name) \
+ DEFVAR_BUFFER_LOCAL_MAGIC (lname, field_name, 0)
+#define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \
+ DEFVAR_BUFFER_LOCAL_1 (lname, field_name, \
+ SYMVAL_CONST_CURRENT_BUFFER_FORWARD, magicfun)
+#define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) \
+ DEFVAR_CONST_BUFFER_LOCAL_MAGIC (lname, field_name, 0)
+
+#define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) \
+ DEFVAR_SYMVAL_FWD (lname, &(buffer_local_flags.field_name), \
+ SYMVAL_DEFAULT_BUFFER_FORWARD, magicfun)
+#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) \
+ DEFVAR_BUFFER_DEFAULTS_MAGIC (lname, field_name, 0)
static void
nuke_all_buffer_slots (struct buffer *b, Lisp_Object zap)
{
zero_lcrecord (b);
+ b->extent_info = Qnil;
+ b->indirect_children = Qnil;
+ b->own_text.line_number_cache = Qnil;
+
#define MARKED_SLOT(x) b->x = (zap);
#include "bufslots.h"
#undef MARKED_SLOT
defs->major_mode = Qfundamental_mode;
defs->mode_name = QSFundamental;
defs->abbrev_table = Qnil; /* real default setup by Lisp code */
- defs->downcase_table = Vascii_downcase_table;
- defs->upcase_table = Vascii_upcase_table;
+
+ defs->downcase_table = Vascii_downcase_table;
+ defs->upcase_table = Vascii_upcase_table;
defs->case_canon_table = Vascii_canon_table;
- defs->case_eqv_table = Vascii_eqv_table;
+ defs->case_eqv_table = Vascii_eqv_table;
#ifdef MULE
- defs->mirror_downcase_table = Vmirror_ascii_downcase_table;
- defs->mirror_upcase_table = Vmirror_ascii_upcase_table;
+ defs->mirror_downcase_table = Vmirror_ascii_downcase_table;
+ defs->mirror_upcase_table = Vmirror_ascii_upcase_table;
defs->mirror_case_canon_table = Vmirror_ascii_canon_table;
- defs->mirror_case_eqv_table = Vmirror_ascii_eqv_table;
+ defs->mirror_case_eqv_table = Vmirror_ascii_eqv_table;
+
defs->category_table = Vstandard_category_table;
#endif /* MULE */
defs->syntax_table = Vstandard_syntax_table;
*/
Lisp_Object always_local_no_default = make_int (0);
Lisp_Object always_local_resettable = make_int (-1);
- Lisp_Object resettable = make_int (-3);
+ Lisp_Object resettable = make_int (-3);
/* Assign the local-flags to the slots that have default values.
The local flag is a bit that is used in the buffer
buffer. */
nuke_all_buffer_slots (&buffer_local_flags, make_int (-2));
- buffer_local_flags.filename = always_local_no_default;
- buffer_local_flags.directory = always_local_no_default;
- buffer_local_flags.backed_up = always_local_no_default;
- buffer_local_flags.saved_size = always_local_no_default;
+ buffer_local_flags.filename = always_local_no_default;
+ buffer_local_flags.directory = always_local_no_default;
+ buffer_local_flags.backed_up = always_local_no_default;
+ buffer_local_flags.saved_size = always_local_no_default;
buffer_local_flags.auto_save_file_name = always_local_no_default;
- buffer_local_flags.read_only = always_local_no_default;
+ buffer_local_flags.read_only = always_local_no_default;
- buffer_local_flags.major_mode = always_local_resettable;
- buffer_local_flags.mode_name = always_local_resettable;
- buffer_local_flags.undo_list = always_local_no_default;
+ buffer_local_flags.major_mode = always_local_resettable;
+ buffer_local_flags.mode_name = always_local_resettable;
+ buffer_local_flags.undo_list = always_local_no_default;
#if 0 /* FSFmacs */
- buffer_local_flags.mark_active = always_local_resettable;
+ buffer_local_flags.mark_active = always_local_resettable;
#endif
buffer_local_flags.point_before_scroll = always_local_resettable;
- buffer_local_flags.file_truename = always_local_no_default;
- buffer_local_flags.invisibility_spec = always_local_resettable;
- buffer_local_flags.file_format = always_local_resettable;
+ buffer_local_flags.file_truename = always_local_no_default;
+ buffer_local_flags.invisibility_spec = always_local_resettable;
+ buffer_local_flags.file_format = always_local_resettable;
buffer_local_flags.generated_modeline_string = always_local_no_default;
- buffer_local_flags.keymap = resettable;
- buffer_local_flags.downcase_table = resettable;
- buffer_local_flags.upcase_table = resettable;
+ buffer_local_flags.keymap = resettable;
+ buffer_local_flags.downcase_table = resettable;
+ buffer_local_flags.upcase_table = resettable;
buffer_local_flags.case_canon_table = resettable;
- buffer_local_flags.case_eqv_table = resettable;
- buffer_local_flags.syntax_table = resettable;
+ buffer_local_flags.case_eqv_table = resettable;
+ buffer_local_flags.syntax_table = resettable;
#ifdef MULE
- buffer_local_flags.category_table = resettable;
+ buffer_local_flags.category_table = resettable;
#endif
- buffer_local_flags.modeline_format = make_int (1);
- buffer_local_flags.abbrev_mode = make_int (2);
- buffer_local_flags.overwrite_mode = make_int (4);
- buffer_local_flags.case_fold_search = make_int (8);
- buffer_local_flags.auto_fill_function = make_int (0x10);
- buffer_local_flags.selective_display = make_int (0x20);
- buffer_local_flags.selective_display_ellipses = make_int (0x40);
- buffer_local_flags.tab_width = make_int (0x80);
- buffer_local_flags.truncate_lines = make_int (0x100);
- buffer_local_flags.ctl_arrow = make_int (0x200);
- buffer_local_flags.fill_column = make_int (0x400);
- buffer_local_flags.left_margin = make_int (0x800);
- buffer_local_flags.abbrev_table = make_int (0x1000);
+ buffer_local_flags.modeline_format = make_int (1<<0);
+ buffer_local_flags.abbrev_mode = make_int (1<<1);
+ buffer_local_flags.overwrite_mode = make_int (1<<2);
+ buffer_local_flags.case_fold_search = make_int (1<<3);
+ buffer_local_flags.auto_fill_function = make_int (1<<4);
+ buffer_local_flags.selective_display = make_int (1<<5);
+ buffer_local_flags.selective_display_ellipses = make_int (1<<6);
+ buffer_local_flags.tab_width = make_int (1<<7);
+ buffer_local_flags.truncate_lines = make_int (1<<8);
+ buffer_local_flags.ctl_arrow = make_int (1<<9);
+ buffer_local_flags.fill_column = make_int (1<<10);
+ buffer_local_flags.left_margin = make_int (1<<11);
+ buffer_local_flags.abbrev_table = make_int (1<<12);
#ifdef REGION_CACHE_NEEDS_WORK
- buffer_local_flags.cache_long_line_scans = make_int (0x2000);
+ buffer_local_flags.cache_long_line_scans = make_int (1<<13);
#endif
#ifdef FILE_CODING
- buffer_local_flags.buffer_file_coding_system = make_int (0x4000);
+ buffer_local_flags.buffer_file_coding_system = make_int (1<<14);
#endif
- /* #### Warning, 0x4000000 (that's six zeroes) is the largest number
- currently allowable due to the XINT() handling of this value.
- With some rearrangement you can get 4 more bits. */
+ /* #### Warning: 1<<28 is the largest number currently allowable
+ due to the XINT() handling of this value. With some
+ rearrangement you can get 3 more bits. */
}
DEFVAR_BUFFER_DEFAULTS ("default-modeline-format", modeline_format /*
The default value for this variable (which is normally used for
buffers without associated files) is also used when automatic
detection of a file's encoding is called for and there was no
-discernable encoding in the file (i.e. it was entirely or almost
+discernible encoding in the file (i.e. it was entirely or almost
entirely ASCII). The default value should generally *not* be set to
nil (equivalent to `no-conversion'), because if extended characters
are ever inserted into the buffer, they will be lost when the file is
variables just mentioned, which are intended to be used for
global environment specification.
*/ );
-#endif
+#endif /* FILE_CODING */
DEFVAR_BUFFER_LOCAL ("auto-fill-function", auto_fill_function /*
Function called (if non-nil) to perform auto-fill.
initial_directory[rc + 1] = '\0';
}
/* XEmacs change: store buffer's default directory
- using prefered (i.e. as defined at compile-time)
+ using preferred (i.e. as defined at compile-time)
directory separator. --marcpa */
#ifdef DOS_NT
#define CORRECT_DIR_SEPS(s) \
x = wrong_type_argument (Qbuffer_live_p, (x)); \
} while (0)
+\f
#define BUFFER_BASE_BUFFER(b) ((b)->base_buffer ? (b)->base_buffer : (b))
/* Map over buffers sharing the same text as MPS_BUF. MPS_BUFVAR is a
)
\f
+
+/************************************************************************/
+/* */
+/* working with raw internal-format data */
+/* */
+/************************************************************************/
+
/* NOTE: In all the following macros, we follow these rules concerning
multiple evaluation of the arguments:
denoted with the word "unsafe" in their name and are generally
meant to be called only by other macros that have already
stored the calling values in temporary variables.
- */
-/************************************************************************/
-/* */
-/* working with raw internal-format data */
-/* */
-/************************************************************************/
-
-/* Use these on contiguous strings of data. If the text you're
- operating on is known to come from a buffer, use the buffer-level
- functions below -- they know about the gap and may be more
- efficient. */
-/* Functions are as follows:
+ Use the following functions/macros on contiguous strings of data.
+ If the text you're operating on is known to come from a buffer, use
+ the buffer-level functions below -- they know about the gap and may
+ be more efficient.
- (A) For working with charptr's (pointers to internally-formatted text):
- -----------------------------------------------------------------------
+ (A) For working with charptr's (pointers to internally-formatted text):
+ -----------------------------------------------------------------------
- VALID_CHARPTR_P(ptr):
+ VALID_CHARPTR_P (ptr):
Given a charptr, does it point to the beginning of a character?
- ASSERT_VALID_CHARPTR(ptr):
+ ASSERT_VALID_CHARPTR (ptr):
If error-checking is enabled, assert that the given charptr
- points to the beginning of a character. Otherwise, do nothing.
+ points to the beginning of a character. Otherwise, do nothing.
- INC_CHARPTR(ptr):
+ INC_CHARPTR (ptr):
Given a charptr (assumed to point at the beginning of a character),
modify that pointer so it points to the beginning of the next
character.
- DEC_CHARPTR(ptr):
+ DEC_CHARPTR (ptr):
Given a charptr (assumed to point at the beginning of a
character or at the very end of the text), modify that pointer
so it points to the beginning of the previous character.
- VALIDATE_CHARPTR_BACKWARD(ptr):
+ VALIDATE_CHARPTR_BACKWARD (ptr):
Make sure that PTR is pointing to the beginning of a character.
- If not, back up until this is the case. Note that there are not
+ If not, back up until this is the case. Note that there are not
too many places where it is legitimate to do this sort of thing.
It's an error if you're passed an "invalid" char * pointer.
NOTE: PTR *must* be pointing to a valid part of the string (i.e.
not the very end, unless the string is zero-terminated or
something) in order for this function to not cause crashes.
- VALIDATE_CHARPTR_FORWARD(ptr):
+ VALIDATE_CHARPTR_FORWARD (ptr):
Make sure that PTR is pointing to the beginning of a character.
If not, move forward until this is the case. Note that there
are not too many places where it is legitimate to do this sort
section of internally-formatted text:
--------------------------------------------------------------
- bytecount_to_charcount(ptr, nbi):
+ bytecount_to_charcount (ptr, nbi):
Given a pointer to a text string and a length in bytes,
return the equivalent length in characters.
- charcount_to_bytecount(ptr, nch):
+ charcount_to_bytecount (ptr, nch):
Given a pointer to a text string and a length in characters,
return the equivalent length in bytes.
- charptr_n_addr(ptr, n):
+ charptr_n_addr (ptr, n):
Return a pointer to the beginning of the character offset N
(in characters) from PTR.
- charptr_length(ptr):
- Given a zero-terminated pointer to Emacs characters,
- return the number of Emacs characters contained within.
-
(C) For retrieving or changing the character pointed to by a charptr:
---------------------------------------------------------------------
- charptr_emchar(ptr):
+ charptr_emchar (ptr):
Retrieve the character pointed to by PTR as an Emchar.
- charptr_emchar_n(ptr, n):
+ charptr_emchar_n (ptr, n):
Retrieve the character at offset N (in characters) from PTR,
as an Emchar.
- set_charptr_emchar(ptr, ch):
+ set_charptr_emchar (ptr, ch):
Store the character CH (an Emchar) as internally-formatted
text starting at PTR. Return the number of bytes stored.
- charptr_copy_char(ptr, ptr2):
+ charptr_copy_char (ptr, ptr2):
Retrieve the character pointed to by PTR and store it as
internally-formatted text in PTR2.
in mule-charset.h, for retrieving the charset of an Emchar
and such. These are only valid when MULE is defined.]
- valid_char_p(ch):
+ valid_char_p (ch):
Return whether the given Emchar is valid.
- CHARP(ch):
- Return whether the given Lisp_Object is a valid character.
- This is approximately the same as saying the Lisp_Object is
- an int whose value is a valid Emchar. (But not exactly
- because when MULE is not defined, we allow arbitrary values
- in all but the lowest 8 bits and mask them off, for backward
- compatibility.)
-
- CHECK_CHAR_COERCE_INT(ch):
- Signal an error if CH is not a valid character as per CHARP().
- Also canonicalize the value into a valid Emchar, as necessary.
- (This only means anything when MULE is not defined.)
+ CHARP (ch):
+ Return whether the given Lisp_Object is a character.
- COERCE_CHAR(ch):
- Coerce an object that is known to satisfy CHARP() into a
- valid Emchar.
+ CHECK_CHAR_COERCE_INT (ch):
+ Signal an error if CH is not a valid character or integer Lisp_Object.
+ If CH is an integer Lisp_Object, convert it to a character Lisp_Object,
+ but merely by repackaging, without performing tests for char validity.
MAX_EMCHAR_LEN:
Maximum number of buffer bytes per Emacs character.
method because it doesn't have easy access to the first byte of
the character it's moving over. */
-#define real_inc_charptr_fun(ptr) \
- ((ptr) += REP_BYTES_BY_FIRST_BYTE (* (unsigned char *) (ptr)))
-#ifdef ERROR_CHECK_BUFPOS
-#define inc_charptr_fun(ptr) (ASSERT_VALID_CHARPTR (ptr), \
- real_inc_charptr_fun (ptr))
-#else
-#define inc_charptr_fun(ptr) real_inc_charptr_fun (ptr)
-#endif
+#define REAL_INC_CHARPTR(ptr) \
+ ((void) ((ptr) += REP_BYTES_BY_FIRST_BYTE (* (unsigned char *) (ptr))))
-#define REAL_INC_CHARPTR(ptr) ((void) (real_inc_charptr_fun (ptr)))
+#define REAL_DEC_CHARPTR(ptr) do { \
+ (ptr)--; \
+} while (!VALID_CHARPTR_P (ptr))
+#ifdef ERROR_CHECK_BUFPOS
#define INC_CHARPTR(ptr) do { \
ASSERT_VALID_CHARPTR (ptr); \
REAL_INC_CHARPTR (ptr); \
} while (0)
-#define REAL_DEC_CHARPTR(ptr) do { \
- (ptr)--; \
-} while (!VALID_CHARPTR_P (ptr))
-
-#ifdef ERROR_CHECK_BUFPOS
-#define DEC_CHARPTR(ptr) do { \
- CONST Bufbyte *__dcptr__ = (ptr); \
- CONST Bufbyte *__dcptr2__ = __dcptr__; \
- REAL_DEC_CHARPTR (__dcptr2__); \
- assert (__dcptr__ - __dcptr2__ == \
- REP_BYTES_BY_FIRST_BYTE (*__dcptr2__)); \
- (ptr) = __dcptr2__; \
+#define DEC_CHARPTR(ptr) do { \
+ CONST Bufbyte *dc_ptr1 = (ptr); \
+ CONST Bufbyte *dc_ptr2 = dc_ptr1; \
+ REAL_DEC_CHARPTR (dc_ptr2); \
+ assert (dc_ptr1 - dc_ptr2 == \
+ REP_BYTES_BY_FIRST_BYTE (*dc_ptr2)); \
+ (ptr) = dc_ptr2; \
} while (0)
-#else
+
+#else /* ! ERROR_CHECK_BUFPOS */
+#define INC_CHARPTR(ptr) REAL_INC_CHARPTR (ptr)
#define DEC_CHARPTR(ptr) REAL_DEC_CHARPTR (ptr)
-#endif
+#endif /* ! ERROR_CHECK_BUFPOS */
#ifdef MULE
the end of the string. */
#define VALIDATE_CHARPTR_FORWARD(ptr) do { \
- Bufbyte *__vcfptr__ = (ptr); \
- VALIDATE_CHARPTR_BACKWARD (__vcfptr__); \
- if (__vcfptr__ != (ptr)) \
+ Bufbyte *vcf_ptr = (ptr); \
+ VALIDATE_CHARPTR_BACKWARD (vcf_ptr); \
+ if (vcf_ptr != (ptr)) \
{ \
- (ptr) = __vcfptr__; \
+ (ptr) = vcf_ptr; \
INC_CHARPTR (ptr); \
} \
} while (0)
return ptr + charcount_to_bytecount (ptr, offset);
}
-INLINE Charcount charptr_length (CONST Bufbyte *ptr);
-INLINE Charcount
-charptr_length (CONST Bufbyte *ptr)
-{
- return bytecount_to_charcount (ptr, strlen ((CONST char *) ptr));
-}
-
-
/* -------------------------------------------------------------------- */
/* (C) For retrieving or changing the character pointed to by a charptr */
/* -------------------------------------------------------------------- */
INLINE int
valid_char_p (Emchar ch)
{
- return (ch >= 0 && ch <= 255) || non_ascii_valid_char_p (ch);
+ return ((unsigned int) (ch) <= 0xff) || non_ascii_valid_char_p (ch);
}
#else /* not MULE */
-#define valid_char_p(ch) ((unsigned int) (ch) <= 255)
+#define valid_char_p(ch) ((unsigned int) (ch) <= 0xff)
#endif /* not MULE */
results with stupid compilers. */
#ifdef MULE
-# define VALIDATE_BYTIND_BACKWARD(buf, x) do \
-{ \
- Bufbyte *__ibptr = BI_BUF_BYTE_ADDRESS (buf, x); \
- while (!BUFBYTE_FIRST_BYTE_P (*__ibptr)) \
- __ibptr--, (x)--; \
+# define VALIDATE_BYTIND_BACKWARD(buf, x) do { \
+ Bufbyte *VBB_ptr = BI_BUF_BYTE_ADDRESS (buf, x); \
+ while (!BUFBYTE_FIRST_BYTE_P (*VBB_ptr)) \
+ VBB_ptr--, (x)--; \
} while (0)
#else
# define VALIDATE_BYTIND_BACKWARD(buf, x)
results with stupid compilers. */
#ifdef MULE
-# define VALIDATE_BYTIND_FORWARD(buf, x) do \
-{ \
- Bufbyte *__ibptr = BI_BUF_BYTE_ADDRESS (buf, x); \
- while (!BUFBYTE_FIRST_BYTE_P (*__ibptr)) \
- __ibptr++, (x)++; \
+# define VALIDATE_BYTIND_FORWARD(buf, x) do { \
+ Bufbyte *VBF_ptr = BI_BUF_BYTE_ADDRESS (buf, x); \
+ while (!BUFBYTE_FIRST_BYTE_P (*VBF_ptr)) \
+ VBF_ptr++, (x)++; \
} while (0)
#else
# define VALIDATE_BYTIND_FORWARD(buf, x)
Extcount gceda_len_out; \
CONST Bufbyte *gceda_ptr_in = (ptr); \
Extbyte *gceda_ptr_out = \
- convert_to_external_format (gceda_ptr_in, gceda_len_in, \
+ convert_to_external_format (gceda_ptr_in, gceda_len_in, \
&gceda_len_out, fmt); \
/* If the new string is identical to the old (will be the case most \
of the time), just return the same string back. This saves \
!memcmp (gceda_ptr_in, gceda_ptr_out, gceda_len_out)) \
{ \
(ptr_out) = (Extbyte *) gceda_ptr_in; \
- (len_out) = (Extcount) gceda_len_in; \
} \
else \
{ \
(ptr_out) = (Extbyte *) alloca (1 + gceda_len_out); \
memcpy ((void *) ptr_out, gceda_ptr_out, 1 + gceda_len_out); \
- (len_out) = (Extcount) gceda_len_out; \
} \
+ (len_out) = gceda_len_out; \
} while (0)
#else /* ! MULE */
{ \
Extcount gcida_len_in = (Extcount) (len); \
Bytecount gcida_len_out; \
- CONST Extbyte *gcida_ptr_in = (ptr); \
+ CONST Extbyte *gcida_ptr_in = (ptr); \
Bufbyte *gcida_ptr_out = \
- convert_from_external_format (gcida_ptr_in, gcida_len_in, \
+ convert_from_external_format (gcida_ptr_in, gcida_len_in, \
&gcida_len_out, fmt); \
/* If the new string is identical to the old (will be the case most \
of the time), just return the same string back. This saves \
!memcmp (gcida_ptr_in, gcida_ptr_out, gcida_len_out)) \
{ \
(ptr_out) = (Bufbyte *) gcida_ptr_in; \
- (len_out) = (Bytecount) gcida_len_in; \
} \
else \
{ \
(ptr_out) = (Extbyte *) alloca (1 + gcida_len_out); \
memcpy ((void *) ptr_out, gcida_ptr_out, 1 + gcida_len_out); \
- (len_out) = gcida_len_out; \
} \
+ (len_out) = gcida_len_out; \
} while (0)
#else /* ! MULE */
#else /* !REL_ALLOC */
#define BUFFER_ALLOC(data,size)\
- ((void) (data = xnew_array (Bufbyte, size)))
+ (data = xnew_array (Bufbyte, size))
#define BUFFER_REALLOC(data,size)\
((Bufbyte *) xrealloc (data, (size) * sizeof(Bufbyte)))
/* Avoid excess parentheses, or syntax errors may rear their heads. */
void convert_bufbyte_string_into_emchar_dynarr (CONST Bufbyte *str,
Bytecount len,
Emchar_dynarr *dyn);
-int convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str,
- Bytecount len,
- Emchar *arr);
+Charcount convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str,
+ Bytecount len,
+ Emchar *arr);
void convert_emchar_string_into_bufbyte_dynarr (Emchar *arr, int nels,
Bufbyte_dynarr *dyn);
Bufbyte *convert_emchar_string_into_malloced_string (Emchar *arr, int nels,
typically used to convert between uppercase and lowercase. For
compatibility reasons, trt tables are currently in the form of
a Lisp string of 256 characters, specifying the conversion for each
- of the first 256 Emacs characters (i.e. the 256 extended-ASCII
- characters). This should be generalized at some point to support
- conversions for all of the allowable Mule characters.
+ of the first 256 Emacs characters (i.e. the 256 Latin-1 characters).
+ This should be generalized at some point to support conversions for
+ all of the allowable Mule characters.
*/
/* The _1 macros are named as such because they assume that you have
return (DOWNCASE_TABLE_OF (buf, ch) == ch) ? UPCASE_TABLE_OF (buf, ch) : ch;
}
-/* Upcase a character known to be not upper case. */
+/* Upcase a character known to be not upper case. Unused. */
#define UPCASE1(buf, ch) UPCASE_TABLE_OF (buf, ch)
Specifically, this lists those variables that have
a buffer-local value in this buffer: i.e. those
whose value does not shadow the default value.
- (Remember that for any particlar variable created
+ (Remember that for any particular variable created
with `make-local-variable' or `make-variable-buffer-local',
it will have a per-buffer value in some buffers and a
default value in others.)
/* 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,
}
DEFUN ("upcase-word", Fupcase_word, 1, 2, "p", /*
-Convert following word (or ARG words) to upper case, moving over.
+Convert following word (or N words) to upper case, moving over.
With negative argument, convert previous words but do not move.
See also `capitalize-word'.
Optional second arg BUFFER defaults to the current buffer.
*/
- (arg, buffer))
+ (n, buffer))
{
/* This function can GC */
- return casify_word (CASE_UP, arg, buffer);
+ return casify_word (CASE_UP, n, buffer);
}
DEFUN ("downcase-word", Fdowncase_word, 1, 2, "p", /*
-Convert following word (or ARG words) to lower case, moving over.
+Convert following word (or N words) to lower case, moving over.
With negative argument, convert previous words but do not move.
Optional second arg BUFFER defaults to the current buffer.
*/
- (arg, buffer))
+ (n, buffer))
{
/* This function can GC */
- return casify_word (CASE_DOWN, arg, buffer);
+ return casify_word (CASE_DOWN, n, buffer);
}
DEFUN ("capitalize-word", Fcapitalize_word, 1, 2, "p", /*
-Capitalize the following word (or ARG words), moving over.
+Capitalize the following word (or N words), moving over.
This gives the word(s) a first character in upper case
and the rest lower case.
With negative argument, capitalize previous words but do not move.
Optional second arg BUFFER defaults to the current buffer.
*/
- (arg, buffer))
+ (n, buffer))
{
/* This function can GC */
- return casify_word (CASE_CAPITALIZE, arg, buffer);
+ return casify_word (CASE_CAPITALIZE, n, buffer);
}
\f
#include "buffer.h"
#include "chartab.h"
-#include "commands.h"
#include "syntax.h"
Lisp_Object Qchar_tablep, Qchar_table;
for (i = 0; i < 96; i++)
{
- (markobj) (cte->level2[i]);
+ markobj (cte->level2[i]);
}
return Qnil;
}
int i;
for (i = 0; i < NUM_ASCII_CHARS; i++)
- (markobj) (ct->ascii[i]);
+ markobj (ct->ascii[i]);
#ifdef MULE
for (i = 0; i < NUM_LEADING_BYTES; i++)
- (markobj) (ct->level1[i]);
+ markobj (ct->level1[i]);
#endif
return ct->mirror_table;
}
/* WARNING: All functions of this nature need to be written extremely
carefully to avoid crashes during GC. Cf. prune_specifiers()
- and prune_weak_hashtables(). */
+ and prune_weak_hash_tables(). */
void
prune_syntax_tables (int (*obj_marked_p) (Lisp_Object))
!GC_NILP (rest);
rest = XCHAR_TABLE (rest)->next_table)
{
- if (! ((*obj_marked_p) (rest)))
+ if (! obj_marked_p (rest))
{
/* This table is garbage. Remove it from the list. */
if (GC_NILP (prev))
{
switch (type)
{
+ default: abort();
case CHAR_TABLE_TYPE_GENERIC: return Qgeneric;
case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax;
case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay;
case CHAR_TABLE_TYPE_CATEGORY: return Qcategory;
#endif
}
-
- abort ();
- return Qnil; /* not reached */
}
static enum char_table_type
#include "commands.h"
#include "frame.h"
#include "events.h"
-#include "macros.h"
#include "window.h"
/* Current depth in recursive edits. */
Lisp_Object Vself_insert_face_command;
\f
DEFUN ("forward-char", Fforward_char, 0, 2, "_p", /*
-Move point right ARG characters (left if ARG negative).
+Move point right N characters (left if N negative).
On attempt to pass end of buffer, stop and signal `end-of-buffer'.
On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'.
On reaching end of buffer, stop and signal error.
*/
- (arg, buffer))
+ (n, buffer))
{
struct buffer *buf = decode_buffer (buffer, 1);
+ EMACS_INT count;
- if (NILP (arg))
- arg = make_int (1);
+ if (NILP (n))
+ count = 1;
else
- CHECK_INT (arg);
+ {
+ CHECK_INT (n);
+ count = XINT (n);
+ }
- /* This used to just set point to point + XINT (arg), and then check
+ /* This used to just set point to point + XINT (n), and then check
to see if it was within boundaries. But now that SET_PT can
potentially do a lot of stuff (calling entering and exiting
hooks, etcetera), that's not a good approach. So we validate the
proposed position, then set point. */
{
- Bufpos new_point = BUF_PT (buf) + XINT (arg);
+ Bufpos new_point = BUF_PT (buf) + count;
if (new_point < BUF_BEGV (buf))
{
}
DEFUN ("backward-char", Fbackward_char, 0, 2, "_p", /*
-Move point left ARG characters (right if ARG negative).
+Move point left N characters (right if N negative).
On attempt to pass end of buffer, stop and signal `end-of-buffer'.
On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'.
*/
- (arg, buffer))
+ (n, buffer))
{
- if (NILP (arg))
- arg = make_int (1);
+ if (NILP (n))
+ n = make_int (-1);
else
- CHECK_INT (arg);
-
- XSETINT (arg, - XINT (arg));
- return Fforward_char (arg, buffer);
+ {
+ CHECK_INT (n);
+ XSETINT (n, - XINT (n));
+ }
+ return Fforward_char (n, buffer);
}
DEFUN ("forward-line", Fforward_line, 0, 2, "_p", /*
-Move ARG lines forward (backward if ARG is negative).
-Precisely, if point is on line I, move to the start of line I + ARG.
+Move N lines forward (backward if N is negative).
+Precisely, if point is on line I, move to the start of line I + N.
If there isn't room, go as far as possible (no error).
Returns the count of lines left to move. If moving forward,
-that is ARG - number of lines moved; if backward, ARG + number moved.
-With positive ARG, a non-empty line at the end counts as one line
+that is N - number of lines moved; if backward, N + number moved.
+With positive N, a non-empty line at the end counts as one line
successfully moved (for the return value).
If BUFFER is nil, the current buffer is assumed.
*/
- (arg, buffer))
+ (n, buffer))
{
struct buffer *buf = decode_buffer (buffer, 1);
Bufpos pos2 = BUF_PT (buf);
Bufpos pos;
EMACS_INT count, shortage, negp;
- if (NILP (arg))
+ if (NILP (n))
count = 1;
else
{
- CHECK_INT (arg);
- count = XINT (arg);
+ CHECK_INT (n);
+ count = XINT (n);
}
negp = count <= 0;
If scan reaches end of buffer, return that position.
This function does not move point.
*/
- (arg, buffer))
+ (n, buffer))
{
struct buffer *b = decode_buffer (buffer, 1);
REGISTER int orig, end;
XSETBUFFER (buffer, b);
- if (NILP (arg))
- arg = make_int (1);
+ if (NILP (n))
+ n = make_int (0);
else
- CHECK_INT (arg);
+ {
+ CHECK_INT (n);
+ n = make_int (XINT (n) - 1);
+ }
- orig = BUF_PT(b);
- Fforward_line (make_int (XINT (arg) - 1), buffer);
- end = BUF_PT(b);
- BUF_SET_PT(b, orig);
+ orig = BUF_PT (b);
+ Fforward_line (n, buffer);
+ end = BUF_PT (b);
+ BUF_SET_PT (b, orig);
return make_int (end);
}
DEFUN ("beginning-of-line", Fbeginning_of_line, 0, 2, "_p", /*
Move point to beginning of current line.
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
+With argument N not nil or 1, move forward N - 1 lines first.
If scan reaches end of buffer, stop there without error.
If BUFFER is nil, the current buffer is assumed.
*/
- (arg, buffer))
+ (n, buffer))
{
struct buffer *b = decode_buffer (buffer, 1);
- BUF_SET_PT(b, XINT (Fpoint_at_bol(arg, buffer)));
+ BUF_SET_PT (b, XINT (Fpoint_at_bol (n, buffer)));
return Qnil;
}
If scan reaches end of buffer, return that position.
This function does not move point.
*/
- (arg, buffer))
+ (n, buffer))
{
struct buffer *buf = decode_buffer (buffer, 1);
+ int count;
- XSETBUFFER (buffer, buf);
-
- if (NILP (arg))
- arg = make_int (1);
+ if (NILP (n))
+ count = 1;
else
- CHECK_INT (arg);
+ {
+ CHECK_INT (n);
+ count = XINT (n);
+ }
return make_int (find_before_next_newline (buf, BUF_PT (buf), 0,
- XINT (arg) - (XINT (arg) <= 0)));
+ count - (count <= 0)));
}
DEFUN ("end-of-line", Fend_of_line, 0, 2, "_p", /*
Move point to end of current line.
-With argument ARG not nil or 1, move forward ARG - 1 lines first.
+With argument N not nil or 1, move forward N - 1 lines first.
If scan reaches end of buffer, stop there without error.
If BUFFER is nil, the current buffer is assumed.
*/
- (arg, buffer))
+ (n, buffer))
{
struct buffer *b = decode_buffer (buffer, 1);
- BUF_SET_PT(b, XINT (Fpoint_at_eol (arg, buffer)));
+ BUF_SET_PT (b, XINT (Fpoint_at_eol (n, buffer)));
return Qnil;
}
DEFUN ("delete-char", Fdelete_char, 1, 2, "*p\nP", /*
-Delete the following ARG characters (previous, with negative arg).
+Delete the following N characters (previous, with negative N).
Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
-Interactively, ARG is the prefix arg, and KILLFLAG is set if
-ARG was explicitly specified.
+Interactively, N is the prefix arg, and KILLFLAG is set if
+N was explicitly specified.
*/
- (arg, killflag))
+ (n, killflag))
{
/* This function can GC */
Bufpos pos;
struct buffer *buf = current_buffer;
+ int count;
- CHECK_INT (arg);
+ CHECK_INT (n);
+ count = XINT (n);
- pos = BUF_PT (buf) + XINT (arg);
+ pos = BUF_PT (buf) + count;
if (NILP (killflag))
{
- if (XINT (arg) < 0)
+ if (count < 0)
{
if (pos < BUF_BEGV (buf))
signal_error (Qbeginning_of_buffer, Qnil);
}
else
{
- call1 (Qkill_forward_chars, arg);
+ call1 (Qkill_forward_chars, n);
}
return Qnil;
}
DEFUN ("delete-backward-char", Fdelete_backward_char, 1, 2, "*p\nP", /*
-Delete the previous ARG characters (following, with negative ARG).
+Delete the previous N characters (following, with negative N).
Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).
-Interactively, ARG is the prefix arg, and KILLFLAG is set if
-ARG was explicitly specified.
+Interactively, N is the prefix arg, and KILLFLAG is set if
+N was explicitly specified.
*/
- (arg, killflag))
+ (n, killflag))
{
/* This function can GC */
- CHECK_INT (arg);
- return Fdelete_char (make_int (-XINT (arg)), killflag);
+ CHECK_INT (n);
+ return Fdelete_char (make_int (- XINT (n)), killflag);
}
static void internal_self_insert (Emchar ch, int noautofill);
Insert the character you type.
Whichever character you type to run this command is inserted.
*/
- (arg))
+ (n))
{
/* This function can GC */
- int n;
Emchar ch;
Lisp_Object c;
- CHECK_INT (arg);
+ int count;
+
+ CHECK_NATNUM (n);
+ count = XINT (n);
if (CHAR_OR_CHAR_INTP (Vlast_command_char))
c = Vlast_command_char;
c = Fevent_to_character (Vlast_command_event, Qnil, Qnil, Qt);
if (NILP (c))
- signal_simple_error ("last typed character has no ASCII equivalent",
+ signal_simple_error ("Last typed character has no ASCII equivalent",
Fcopy_event (Vlast_command_event, Qnil));
CHECK_CHAR_COERCE_INT (c);
- n = XINT (arg);
ch = XCHAR (c);
-#if 0 /* FSFmacs */
- /* #### This optimization won't work because of differences in
- how the start-open and end-open properties default for text
- properties. See internal_self_insert(). */
- if (n >= 2 && NILP (current_buffer->overwrite_mode))
- {
- n -= 2;
- /* The first one might want to expand an abbrev. */
- internal_self_insert (c, 1);
- /* The bulk of the copies of this char can be inserted simply.
- We don't have to handle a user-specified face specially
- because it will get inherited from the first char inserted. */
- Finsert_char (make_char (c), make_int (n), Qt, Qnil);
- /* The last one might want to auto-fill. */
- internal_self_insert (c, 0);
- }
- else
-#endif /* 0 */
- while (n > 0)
- {
- n--;
- internal_self_insert (ch, (n != 0));
- }
+
+ while (count--)
+ internal_self_insert (ch, (count != 0));
+
return Qnil;
}
Lisp_Object overwrite;
struct Lisp_Char_Table *syntax_table;
struct buffer *buf = current_buffer;
+ int tab_width;
overwrite = buf->overwrite_mode;
syntax_table = XCHAR_TABLE (buf->mirror_syntax_table);
|| (c1 != '\n' && BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\n'))
&& (EQ (overwrite, Qoverwrite_mode_binary)
|| BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\t'
- || XINT (buf->tab_width) <= 0
- || XINT (buf->tab_width) > 20
- || !((current_column (buf) + 1) % XINT (buf->tab_width))))
+ || ((tab_width = XINT (buf->tab_width), tab_width <= 0)
+ || tab_width > 20
+ || !((current_column (buf) + 1) % tab_width))))
{
buffer_delete_range (buf, BUF_PT (buf), BUF_PT (buf) + 1, 0);
/* hairy = 2; */
determine where XEmacs' memory is going. */
#undef MEMORY_USAGE_STATS
-/* Define QUANTIFY if using Quantify from Pure/Atria Software.
+/* Define QUANTIFY if using Quantify from Rational/Pure/Atria Software.
This adds some additional calls to control data collection.
It is only intended for use by the developers. */
#undef QUANTIFY
+/* Define QUANTIFY if using Purify from Rational/Pure/Atria Software.
+ It is only intended for use by the developers. */
+#undef PURIFY
+
+#if (defined (QUANTIFY) || defined (PURIFY)) && !defined (XLIB_ILLEGAL_ACCESS)
+#define XLIB_ILLEGAL_ACCESS 1
+#endif
+
/* Define EXTERNAL_WIDGET to compile support for using the editor as a
widget within another program. */
#undef EXTERNAL_WIDGET
/* 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
int x_keysym_map_min_code;
int x_keysym_map_max_code;
int x_keysym_map_keysyms_per_code;
- Lisp_Object x_keysym_map_hashtable;
+ Lisp_Object x_keysym_map_hash_table;
/* frame that holds the WM_COMMAND property; there should be exactly
one of these per device. */
#define DEVICE_X_MOUSE_TIMESTAMP(d) (DEVICE_X_DATA (d)->mouse_timestamp)
#define DEVICE_X_GLOBAL_MOUSE_TIMESTAMP(d) (DEVICE_X_DATA (d)->global_mouse_timestamp)
#define DEVICE_X_LAST_SERVER_TIMESTAMP(d) (DEVICE_X_DATA (d)->last_server_timestamp)
-#define DEVICE_X_KEYSYM_MAP_HASHTABLE(d) (DEVICE_X_DATA (d)->x_keysym_map_hashtable)
+#define DEVICE_X_KEYSYM_MAP_HASH_TABLE(d) (DEVICE_X_DATA (d)->x_keysym_map_hash_table)
/* #define DEVICE_X_X_COMPOSE_STATUS(d) (DEVICE_X_DATA (d)->x_compose_status) */
#ifdef HAVE_XIM
#define DEVICE_X_XIM(d) (DEVICE_X_DATA (d)->xim)
{
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)
always tagged to a particular X window (i.e. frame),
which exists on only one screen; therefore the event won't be
reported multiple times even if there are multiple devices on
- the same physical display. This is an implementational detail
+ the same physical display. This is an implementation detail
specific to X consoles (e.g. under NeXTstep or Windows, this
could be different, and input would come directly from the console).
*/
int depth);
void (*init_image_instance_from_eimage_method) (struct Lisp_Image_Instance *ii,
int width, int height,
- unsigned char *eimage,
+ unsigned char *eimage,
int dest_mask,
Lisp_Object instantiator,
Lisp_Object domain);
Lisp_Object fg, Lisp_Object bg);
#ifdef HAVE_XPM
/* which is more tacky - this or #defines in glyphs.c? */
- void (*xpm_instantiate_method)(Lisp_Object image_instance,
+ void (*xpm_instantiate_method)(Lisp_Object image_instance,
Lisp_Object instantiator,
- Lisp_Object pointer_fg,
+ Lisp_Object pointer_fg,
Lisp_Object pointer_bg,
int dest_mask, Lisp_Object domain);
#endif
#ifdef HAVE_WINDOW_SYSTEM
/* which is more tacky - this or #defines in glyphs.c? */
- void (*xbm_instantiate_method)(Lisp_Object image_instance,
+ void (*xbm_instantiate_method)(Lisp_Object image_instance,
Lisp_Object instantiator,
- Lisp_Object pointer_fg,
+ Lisp_Object pointer_fg,
Lisp_Object pointer_bg,
int dest_mask, Lisp_Object domain);
#endif
/* Call a void-returning console method, if it exists */
#define MAYBE_CONTYPE_METH(meth, m, args) do { \
- struct console_methods *_maybe_contype_meth_meth = (meth); \
- if (HAS_CONTYPE_METH_P (_maybe_contype_meth_meth, m)) \
- CONTYPE_METH (_maybe_contype_meth_meth, m, args); \
+ struct console_methods *maybe_contype_meth_meth = (meth); \
+ if (HAS_CONTYPE_METH_P (maybe_contype_meth_meth, m)) \
+ CONTYPE_METH (maybe_contype_meth_meth, m, args); \
} while (0)
/* Call a console method, if it exists; otherwise return
#define CONSOLE_SELECTED_DEVICE(con) ((con)->selected_device)
#define CONSOLE_SELECTED_FRAME(con) \
DEVICE_SELECTED_FRAME (XDEVICE ((con)->selected_device))
-#define CONSOLE_LAST_NONMINIBUF_FRAME(con) NON_LVALUE ((con)->_last_nonminibuf_frame)
+#define CONSOLE_LAST_NONMINIBUF_FRAME(con) NON_LVALUE ((con)->last_nonminibuf_frame)
#define CONSOLE_QUIT_CHAR(con) ((con)->quit_char)
#define CDFW_CONSOLE(obj) \
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
-Lisp_Object Qconsp, Qsubrp, Qcompiled_functionp;
+Lisp_Object Qconsp, Qsubrp;
Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
int
eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
{
- if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))
- && (debug_issue_ebola_notices >= 2
- || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2)))
+ if (debug_issue_ebola_notices != -42 /* abracadabra */ &&
+ (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))
+ && (debug_issue_ebola_notices >= 2
+ || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))))
{
- stderr_out("Comparison between integer and character is constant nil (");
+ write_c_string ("Comparison between integer and character is constant nil (",
+ Qexternal_debugging_output);
Fprinc (obj1, Qexternal_debugging_output);
- stderr_out (" and ");
+ write_c_string (" and ", Qexternal_debugging_output);
Fprinc (obj2, Qexternal_debugging_output);
- stderr_out (")\n");
+ write_c_string (")\n", Qexternal_debugging_output);
debug_short_backtrace (debug_ebola_backtrace_length);
}
return EQ (obj1, obj2);
}
DEFUN ("consp", Fconsp, 1, 1, 0, /*
-Return t if OBJECT is a cons cell.
+Return t if OBJECT is a cons cell. `nil' is not a cons cell.
*/
(object))
{
}
DEFUN ("atom", Fatom, 1, 1, 0, /*
-Return t if OBJECT is not a cons cell. Atoms include nil.
+Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
*/
(object))
{
}
DEFUN ("listp", Flistp, 1, 1, 0, /*
-Return t if OBJECT is a list. Lists includes nil.
+Return t if OBJECT is a list. `nil' is a list.
*/
(object))
{
}
DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
-Return t if OBJECT is not a list. Lists include nil.
+Return t if OBJECT is not a list. `nil' is a list.
*/
(object))
{
}
DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
-REturn t if OBJECT is a vector.
+Return t if OBJECT is a vector.
*/
(object))
{
*/
(object))
{
- return (CONSP (object) ||
- NILP (object) ||
+ return (LISTP (object) ||
VECTORP (object) ||
STRINGP (object) ||
BIT_VECTORP (object))
return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
}
-DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
-Return t if OBJECT is a byte-compiled function object.
-*/
- (object))
-{
- return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
-}
-
\f
DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
Return t if OBJECT is a character.
*/
(object))
{
- if (CONSP (object)) return Qcons;
- if (SYMBOLP (object)) return Qsymbol;
- if (KEYWORDP (object)) return Qkeyword;
- if (INTP (object)) return Qinteger;
- if (CHARP (object)) return Qcharacter;
- if (STRINGP (object)) return Qstring;
- if (VECTORP (object)) return Qvector;
+ switch (XTYPE (object))
+ {
+#ifndef LRECORD_CONS
+ case Lisp_Type_Cons: return Qcons;
+#endif
+
+#ifndef LRECORD_SYMBOL
+ case Lisp_Type_Symbol: return Qsymbol;
+#endif
- assert (LRECORDP (object));
- return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
+#ifndef LRECORD_STRING
+ case Lisp_Type_String: return Qstring;
+#endif
+
+#ifndef LRECORD_VECTOR
+ case Lisp_Type_Vector: return Qvector;
+#endif
+
+ case Lisp_Type_Record:
+ return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
+
+ case Lisp_Type_Char: return Qcharacter;
+
+ default: return Qinteger;
+ }
}
\f
return newcdr;
}
\f
-/* Find the function at the end of a chain of symbol function indirections. */
+/* Find the function at the end of a chain of symbol function indirections.
-/* If OBJECT is a symbol, find the end of its function chain and
+ If OBJECT is a symbol, find the end of its function chain and
return the value found there. If OBJECT is not a symbol, just
return it. If there is a cycle in the function chain, signal a
cyclic-function-indirection error.
Lisp_Object
indirect_function (Lisp_Object object, int errorp)
{
- Lisp_Object tortoise = object;
- Lisp_Object hare = object;
+#define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
+ Lisp_Object tortoise, hare;
+ int count;
- for (;;)
+ for (hare = tortoise = object, count = 0;
+ SYMBOLP (hare);
+ hare = XSYMBOL (hare)->function, count++)
{
- if (!SYMBOLP (hare) || UNBOUNDP (hare))
- break;
- hare = XSYMBOL (hare)->function;
- if (!SYMBOLP (hare) || UNBOUNDP (hare))
- break;
- hare = XSYMBOL (hare)->function;
-
- tortoise = XSYMBOL (tortoise)->function;
+ if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
+ if (count & 1)
+ tortoise = XSYMBOL (tortoise)->function;
if (EQ (hare, tortoise))
return Fsignal (Qcyclic_function_indirection, list1 (object));
}
- if (UNBOUNDP (hare) && errorp)
- return Fsignal (Qvoid_function, list1 (object));
+ if (errorp && UNBOUNDP (hare))
+ signal_void_function_error (object);
+
return hare;
}
DEFUN ("aref", Faref, 2, 2, 0, /*
Return the element of ARRAY at index INDEX.
-ARRAY may be a vector, bit vector, string, or byte-code object.
-IDX starts at 0.
+ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
*/
- (array, idx))
+ (array, index_))
{
- int idxval;
+ int idx;
retry:
- CHECK_INT_COERCE_CHAR (idx); /* yuck! */
- idxval = XINT (idx);
- if (idxval < 0)
+
+ if (INTP (index_)) idx = XINT (index_);
+ else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
+ else
{
- lose:
- args_out_of_range (array, idx);
+ index_ = wrong_type_argument (Qinteger_or_char_p, index_);
+ goto retry;
}
+
+ if (idx < 0) goto range_error;
+
if (VECTORP (array))
{
- if (idxval >= XVECTOR_LENGTH (array)) goto lose;
- return XVECTOR_DATA (array)[idxval];
+ if (idx >= XVECTOR_LENGTH (array)) goto range_error;
+ return XVECTOR_DATA (array)[idx];
}
else if (BIT_VECTORP (array))
{
- if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
- return make_int (bit_vector_bit (XBIT_VECTOR (array), idxval));
+ if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
+ return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
}
else if (STRINGP (array))
{
- if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose;
- return make_char (string_char (XSTRING (array), idxval));
+ if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
+ return make_char (string_char (XSTRING (array), idx));
}
#ifdef LOSING_BYTECODE
else if (COMPILED_FUNCTIONP (array))
{
/* Weird, gross compatibility kludge */
- return Felt (array, idx);
+ return Felt (array, index_);
}
#endif
else
array = wrong_type_argument (Qarrayp, array);
goto retry;
}
+
+ range_error:
+ args_out_of_range (array, index_);
+ return Qnil; /* not reached */
}
DEFUN ("aset", Faset, 3, 3, 0, /*
-Store into the element of ARRAY at index IDX the value NEWVAL.
-ARRAY may be a vector, bit vector, or string. IDX starts at 0.
+Store into the element of ARRAY at index INDEX the value NEWVAL.
+ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
*/
- (array, idx, newval))
+ (array, index_, newval))
{
- int idxval;
+ int idx;
- CHECK_INT_COERCE_CHAR (idx); /* yuck! */
- if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array))
- array = wrong_type_argument (Qarrayp, array);
+ retry:
- idxval = XINT (idx);
- if (idxval < 0)
+ if (INTP (index_)) idx = XINT (index_);
+ else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
+ else
{
- lose:
- args_out_of_range (array, idx);
+ index_ = wrong_type_argument (Qinteger_or_char_p, index_);
+ goto retry;
}
+
+ if (idx < 0) goto range_error;
+
CHECK_IMPURE (array);
if (VECTORP (array))
{
- if (idxval >= XVECTOR_LENGTH (array)) goto lose;
- XVECTOR_DATA (array)[idxval] = newval;
+ if (idx >= XVECTOR_LENGTH (array)) goto range_error;
+ XVECTOR_DATA (array)[idx] = newval;
}
else if (BIT_VECTORP (array))
{
- if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
+ if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
CHECK_BIT (newval);
- set_bit_vector_bit (XBIT_VECTOR (array), idxval, !ZEROP (newval));
+ set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
}
- else /* string */
+ else if (STRINGP (array))
{
CHECK_CHAR_COERCE_INT (newval);
- if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose;
- set_string_char (XSTRING (array), idxval, XCHAR (newval));
+ if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
+ set_string_char (XSTRING (array), idx, XCHAR (newval));
bump_string_modiff (array);
}
+ else
+ {
+ array = wrong_type_argument (Qarrayp, array);
+ goto retry;
+ }
return newval;
+
+ range_error:
+ args_out_of_range (array, index_);
+ return Qnil; /* not reached */
}
\f
/**********************************************************************/
-/* Compiled-function objects */
+/* Arithmetic functions */
/**********************************************************************/
-
-/* The compiled_function->doc_and_interactive slot uses the minimal
- number of conses, based on compiled_function->flags; it may take
- any of the following forms:
-
- doc
- interactive
- domain
- (doc . interactive)
- (doc . domain)
- (interactive . domain)
- (doc . (interactive . domain))
- */
-
-/* Caller must check flags.interactivep first */
-Lisp_Object
-compiled_function_interactive (struct Lisp_Compiled_Function *b)
+typedef struct
{
- assert (b->flags.interactivep);
- if (b->flags.documentationp && b->flags.domainp)
- return XCAR (XCDR (b->doc_and_interactive));
- else if (b->flags.documentationp)
- return XCDR (b->doc_and_interactive);
- else if (b->flags.domainp)
- return XCAR (b->doc_and_interactive);
-
- /* if all else fails... */
- return b->doc_and_interactive;
-}
+ int int_p;
+ union
+ {
+ int ival;
+ double dval;
+ } c;
+} int_or_double;
-/* Caller need not check flags.documentationp first */
-Lisp_Object
-compiled_function_documentation (struct Lisp_Compiled_Function *b)
-{
- if (! b->flags.documentationp)
- return Qnil;
- else if (b->flags.interactivep && b->flags.domainp)
- return XCAR (b->doc_and_interactive);
- else if (b->flags.interactivep)
- return XCAR (b->doc_and_interactive);
- else if (b->flags.domainp)
- return XCAR (b->doc_and_interactive);
- else
- return b->doc_and_interactive;
-}
-
-/* Caller need not check flags.domainp first */
-Lisp_Object
-compiled_function_domain (struct Lisp_Compiled_Function *b)
-{
- if (! b->flags.domainp)
- return Qnil;
- else if (b->flags.documentationp && b->flags.interactivep)
- return XCDR (XCDR (b->doc_and_interactive));
- else if (b->flags.documentationp)
- return XCDR (b->doc_and_interactive);
- else if (b->flags.interactivep)
- return XCDR (b->doc_and_interactive);
- else
- return b->doc_and_interactive;
-}
-
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
-
-Lisp_Object
-compiled_function_annotation (struct Lisp_Compiled_Function *b)
+static void
+number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
{
- return b->annotated;
-}
-
+ retry:
+ p->int_p = 1;
+ if (INTP (obj)) p->c.ival = XINT (obj);
+ else if (CHARP (obj)) p->c.ival = XCHAR (obj);
+ else if (MARKERP (obj)) p->c.ival = marker_position (obj);
+#ifdef LISP_FLOAT_TYPE
+ else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
#endif
-
-/* used only by Snarf-documentation; there must be doc already. */
-void
-set_compiled_function_documentation (struct Lisp_Compiled_Function *b,
- Lisp_Object new)
-{
- assert (b->flags.documentationp);
- assert (INTP (new) || STRINGP (new));
-
- if (b->flags.interactivep && b->flags.domainp)
- XCAR (b->doc_and_interactive) = new;
- else if (b->flags.interactivep)
- XCAR (b->doc_and_interactive) = new;
- else if (b->flags.domainp)
- XCAR (b->doc_and_interactive) = new;
else
- b->doc_and_interactive = new;
-}
-
-DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
-Return the byte-opcode string of the compiled-function object.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return XCOMPILED_FUNCTION (function)->bytecodes;
-}
-
-DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
-Return the constants vector of the compiled-function object.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return XCOMPILED_FUNCTION (function)->constants;
-}
-
-DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
-Return the max stack depth of the compiled-function object.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return make_int (XCOMPILED_FUNCTION (function)->maxdepth);
-}
-
-DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
-Return the argument list of the compiled-function object.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return XCOMPILED_FUNCTION (function)->arglist;
-}
-
-DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
-Return the interactive spec of the compiled-function object, or nil.
-If non-nil, the return value will be a list whose first element is
-`interactive' and whose second element is the interactive spec.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return XCOMPILED_FUNCTION (function)->flags.interactivep
- ? list2 (Qinteractive,
- compiled_function_interactive (XCOMPILED_FUNCTION (function)))
- : Qnil;
-}
-
-DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
-Return the doc string of the compiled-function object, if available.
-Functions that had their doc strings snarfed into the DOC file will have
-an integer returned instead of a string.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return compiled_function_documentation (XCOMPILED_FUNCTION (function));
-}
-
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
-
-/* Remove the `xx' if you wish to restore this feature */
-xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
-Return the annotation of the compiled-function object, or nil.
-The annotation is a piece of information indicating where this
-compiled-function object came from. Generally this will be
-a symbol naming a function; or a string naming a file, if the
-compiled-function object was not defined in a function; or nil,
-if the compiled-function object was not created as a result of
-a `load'.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return compiled_function_annotation (XCOMPILED_FUNCTION (function));
-}
-
-#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
-
-DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
-Return the domain of the compiled-function object, or nil.
-This is only meaningful if I18N3 was enabled when emacs was compiled.
-*/
- (function))
-{
- CHECK_COMPILED_FUNCTION (function);
- return XCOMPILED_FUNCTION (function)->flags.domainp
- ? compiled_function_domain (XCOMPILED_FUNCTION (function))
- : Qnil;
+ {
+ obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
+ goto retry;
+ }
}
-\f
-/**********************************************************************/
-/* Arithmetic functions */
-/**********************************************************************/
-
-Lisp_Object
-arithcompare (Lisp_Object num1, Lisp_Object num2,
- enum arith_comparison comparison)
+static double
+number_char_or_marker_to_double (Lisp_Object obj)
{
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1);
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2);
-
+ retry:
+ if (INTP (obj)) return (double) XINT (obj);
+ else if (CHARP (obj)) return (double) XCHAR (obj);
+ else if (MARKERP (obj)) return (double) marker_position (obj);
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (num1) || FLOATP (num2))
+ else if (FLOATP (obj)) return XFLOAT_DATA (obj);
+#endif
+ else
{
- double f1 = FLOATP (num1) ? float_data (XFLOAT (num1)) : XINT (num1);
- double f2 = FLOATP (num2) ? float_data (XFLOAT (num2)) : XINT (num2);
-
- switch (comparison)
- {
- case arith_equal: return f1 == f2 ? Qt : Qnil;
- case arith_notequal: return f1 != f2 ? Qt : Qnil;
- case arith_less: return f1 < f2 ? Qt : Qnil;
- case arith_less_or_equal: return f1 <= f2 ? Qt : Qnil;
- case arith_grtr: return f1 > f2 ? Qt : Qnil;
- case arith_grtr_or_equal: return f1 >= f2 ? Qt : Qnil;
- }
+ obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
+ goto retry;
}
-#endif /* LISP_FLOAT_TYPE */
+}
- switch (comparison)
+static int
+integer_char_or_marker_to_int (Lisp_Object obj)
+{
+ retry:
+ if (INTP (obj)) return XINT (obj);
+ else if (CHARP (obj)) return XCHAR (obj);
+ else if (MARKERP (obj)) return marker_position (obj);
+ else
{
- case arith_equal: return XINT (num1) == XINT (num2) ? Qt : Qnil;
- case arith_notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil;
- case arith_less: return XINT (num1) < XINT (num2) ? Qt : Qnil;
- case arith_less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil;
- case arith_grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil;
- case arith_grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil;
+ obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
+ goto retry;
}
-
- abort ();
- return Qnil; /* suppress compiler warning */
}
-static Lisp_Object
-arithcompare_many (enum arith_comparison comparison,
- int nargs, Lisp_Object *args)
-{
- for (; --nargs > 0; args++)
- if (NILP (arithcompare (*args, *(args + 1), comparison)))
- return Qnil;
-
- return Qt;
+#define ARITHCOMPARE_MANY(op) \
+{ \
+ int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
+ Lisp_Object *args_end = args + nargs; \
+ \
+ number_char_or_marker_to_int_or_double (*args++, p); \
+ \
+ while (args < args_end) \
+ { \
+ number_char_or_marker_to_int_or_double (*args++, q); \
+ \
+ if (!((p->int_p && q->int_p) ? \
+ (p->c.ival op q->c.ival) : \
+ ((p->int_p ? (double) p->c.ival : p->c.dval) op \
+ (q->int_p ? (double) q->c.ival : q->c.dval)))) \
+ return Qnil; \
+ \
+ { /* swap */ int_or_double *r = p; p = q; q = r; } \
+ } \
+ return Qt; \
}
DEFUN ("=", Feqlsign, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (arith_equal, nargs, args);
+ ARITHCOMPARE_MANY (==)
}
DEFUN ("<", Flss, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (arith_less, nargs, args);
+ ARITHCOMPARE_MANY (<)
}
DEFUN (">", Fgtr, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (arith_grtr, nargs, args);
+ ARITHCOMPARE_MANY (>)
}
DEFUN ("<=", Fleq, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (arith_less_or_equal, nargs, args);
+ ARITHCOMPARE_MANY (<=)
}
DEFUN (">=", Fgeq, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (arith_grtr_or_equal, nargs, args);
+ ARITHCOMPARE_MANY (>=)
}
DEFUN ("/=", Fneq, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (arith_notequal, nargs, args);
+ Lisp_Object *args_end = args + nargs;
+ Lisp_Object *p, *q;
+
+ /* Unlike all the other comparisons, this is an N*N algorithm.
+ We could use a hash table for nargs > 50 to make this linear. */
+ for (p = args; p < args_end; p++)
+ {
+ int_or_double iod1, iod2;
+ number_char_or_marker_to_int_or_double (*p, &iod1);
+
+ for (q = p + 1; q < args_end; q++)
+ {
+ number_char_or_marker_to_int_or_double (*q, &iod2);
+
+ if (!((iod1.int_p && iod2.int_p) ?
+ (iod1.c.ival != iod2.c.ival) :
+ ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
+ (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
+ return Qnil;
+ }
+ }
+ return Qt;
}
DEFUN ("zerop", Fzerop, 1, 1, 0, /*
*/
(number))
{
- CHECK_INT_OR_FLOAT (number);
-
+ retry:
+ if (INTP (number))
+ return EQ (number, Qzero) ? Qt : Qnil;
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (number))
- return float_data (XFLOAT (number)) == 0.0 ? Qt : Qnil;
+ else if (FLOATP (number))
+ return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
#endif /* LISP_FLOAT_TYPE */
-
- return EQ (number, Qzero) ? Qt : Qnil;
+ else
+ {
+ number = wrong_type_argument (Qnumberp, number);
+ goto retry;
+ }
}
\f
/* Convert between a 32-bit value and a cons of two 16-bit values.
{
char pigbuf[350]; /* see comments in float_to_string */
- float_to_string (pigbuf, float_data (XFLOAT (num)));
+ float_to_string (pigbuf, XFLOAT_DATA (num));
return build_string (pigbuf);
}
#endif /* LISP_FLOAT_TYPE */
if (b == 10)
{
/* Use the system-provided functions for base 10. */
-#if SIZEOF_EMACS_INT == SIZEOF_INT
+#if SIZEOF_EMACS_INT == SIZEOF_INT
return make_int (atoi (p));
#elif SIZEOF_EMACS_INT == SIZEOF_LONG
return make_int (atol (p));
}
}
\f
-enum arithop
- { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
+DEFUN ("+", Fplus, 0, MANY, 0, /*
+Return sum of any number of arguments.
+The arguments should all be numbers, characters or markers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ EMACS_INT iaccum = 0;
+ Lisp_Object *args_end = args + nargs;
-#ifdef LISP_FLOAT_TYPE
-static Lisp_Object
-float_arith_driver (double accum, int argnum, enum arithop code, int nargs,
- Lisp_Object *args)
+ while (args < args_end)
+ {
+ int_or_double iod;
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ iaccum += iod.c.ival;
+ else
+ {
+ double daccum = (double) iaccum + iod.c.dval;
+ while (args < args_end)
+ daccum += number_char_or_marker_to_double (*args++);
+ return make_float (daccum);
+ }
+ }
+
+ return make_int (iaccum);
+}
+
+DEFUN ("-", Fminus, 1, MANY, 0, /*
+Negate number or subtract numbers, characters or markers.
+With one arg, negates it. With more than one arg,
+subtracts all but the first from the first.
+*/
+ (int nargs, Lisp_Object *args))
{
- REGISTER Lisp_Object val;
- double next;
+ EMACS_INT iaccum;
+ double daccum;
+ Lisp_Object *args_end = args + nargs;
+ int_or_double iod;
- for (; argnum < nargs; argnum++)
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
+ else
{
- /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
- val = args[argnum];
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
+ daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
+ goto do_float;
+ }
- if (FLOATP (val))
+ while (args < args_end)
+ {
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ iaccum -= iod.c.ival;
+ else
{
- next = float_data (XFLOAT (val));
+ daccum = (double) iaccum - iod.c.dval;
+ goto do_float;
}
+ }
+
+ return make_int (iaccum);
+
+ do_float:
+ for (; args < args_end; args++)
+ daccum -= number_char_or_marker_to_double (*args);
+ return make_float (daccum);
+}
+
+DEFUN ("*", Ftimes, 0, MANY, 0, /*
+Return product of any number of arguments.
+The arguments should all be numbers, characters or markers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ EMACS_INT iaccum = 1;
+ Lisp_Object *args_end = args + nargs;
+
+ while (args < args_end)
+ {
+ int_or_double iod;
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ iaccum *= iod.c.ival;
else
{
- args[argnum] = val; /* runs into a compiler bug. */
- next = XINT (args[argnum]);
+ double daccum = (double) iaccum * iod.c.dval;
+ while (args < args_end)
+ daccum *= number_char_or_marker_to_double (*args++);
+ return make_float (daccum);
}
- switch (code)
+ }
+
+ return make_int (iaccum);
+}
+
+DEFUN ("/", Fquo, 1, MANY, 0, /*
+Return first argument divided by all the remaining arguments.
+The arguments must be numbers, characters or markers.
+With one argument, reciprocates the argument.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ EMACS_INT iaccum;
+ double daccum;
+ Lisp_Object *args_end = args + nargs;
+ int_or_double iod;
+
+ if (nargs == 1)
+ iaccum = 1;
+ else
+ {
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ iaccum = iod.c.ival;
+ else
{
- case Aadd:
- accum += next;
- break;
- case Asub:
- if (!argnum && nargs != 1)
- next = - next;
- accum -= next;
- break;
- case Amult:
- accum *= next;
- break;
- case Adiv:
- if (!argnum)
- accum = next;
- else
- {
- if (next == 0)
- Fsignal (Qarith_error, Qnil);
- accum /= next;
- }
- break;
- case Alogand:
- case Alogior:
- case Alogxor:
- return wrong_type_argument (Qinteger_char_or_marker_p, val);
- case Amax:
- if (!argnum || isnan (next) || next > accum)
- accum = next;
- break;
- case Amin:
- if (!argnum || isnan (next) || next < accum)
- accum = next;
- break;
+ daccum = iod.c.dval;
+ goto divide_floats;
}
}
- return make_float (accum);
+ while (args < args_end)
+ {
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ {
+ if (iod.c.ival == 0) goto divide_by_zero;
+ iaccum /= iod.c.ival;
+ }
+ else
+ {
+ if (iod.c.dval == 0) goto divide_by_zero;
+ daccum = (double) iaccum / iod.c.dval;
+ goto divide_floats;
+ }
+ }
+
+ return make_int (iaccum);
+
+ divide_floats:
+ for (; args < args_end; args++)
+ {
+ double dval = number_char_or_marker_to_double (*args);
+ if (dval == 0) goto divide_by_zero;
+ daccum /= dval;
+ }
+ return make_float (daccum);
+
+ divide_by_zero:
+ Fsignal (Qarith_error, Qnil);
+ return Qnil; /* not reached */
}
-#endif /* LISP_FLOAT_TYPE */
-static Lisp_Object
-arith_driver (enum arithop code, int nargs, Lisp_Object *args)
+DEFUN ("max", Fmax, 1, MANY, 0, /*
+Return largest of all the arguments.
+All arguments must be numbers, characters or markers.
+The value is always a number; markers and characters are converted
+to numbers.
+*/
+ (int nargs, Lisp_Object *args))
{
- Lisp_Object val;
- REGISTER int argnum;
- REGISTER EMACS_INT accum = 0;
- REGISTER EMACS_INT next;
+ EMACS_INT imax;
+ double dmax;
+ Lisp_Object *args_end = args + nargs;
+ int_or_double iod;
- switch (code)
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ imax = iod.c.ival;
+ else
{
- case Alogior:
- case Alogxor:
- case Aadd:
- case Asub:
- accum = 0; break;
- case Amult:
- accum = 1; break;
- case Alogand:
- accum = -1; break;
- case Adiv:
- case Amax:
- case Amin:
- accum = 0; break;
- default:
- abort ();
+ dmax = iod.c.dval;
+ goto max_floats;
}
- for (argnum = 0; argnum < nargs; argnum++)
+ while (args < args_end)
{
- /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
- val = args[argnum];
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
-
-#ifdef LISP_FLOAT_TYPE
- if (FLOATP (val)) /* time to do serious math */
- return float_arith_driver ((double) accum, argnum, code,
- nargs, args);
-#endif /* LISP_FLOAT_TYPE */
- args[argnum] = val; /* runs into a compiler bug. */
- next = XINT (args[argnum]);
- switch (code)
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
{
- case Aadd: accum += next; break;
- case Asub:
- if (!argnum && nargs != 1)
- next = - next;
- accum -= next;
- break;
- case Amult: accum *= next; break;
- case Adiv:
- if (!argnum) accum = next;
- else
- {
- if (next == 0)
- Fsignal (Qarith_error, Qnil);
- accum /= next;
- }
- break;
- case Alogand: accum &= next; break;
- case Alogior: accum |= next; break;
- case Alogxor: accum ^= next; break;
- case Amax: if (!argnum || next > accum) accum = next; break;
- case Amin: if (!argnum || next < accum) accum = next; break;
+ if (imax < iod.c.ival) imax = iod.c.ival;
+ }
+ else
+ {
+ dmax = (double) imax;
+ if (dmax < iod.c.dval) dmax = iod.c.dval;
+ goto max_floats;
}
}
- XSETINT (val, accum);
- return val;
+ return make_int (imax);
+
+ max_floats:
+ while (args < args_end)
+ {
+ double dval = number_char_or_marker_to_double (*args++);
+ if (dmax < dval) dmax = dval;
+ }
+ return make_float (dmax);
}
-DEFUN ("+", Fplus, 0, MANY, 0, /*
-Return sum of any number of arguments.
-The arguments should all be numbers, characters or markers.
+DEFUN ("min", Fmin, 1, MANY, 0, /*
+Return smallest of all the arguments.
+All arguments must be numbers, characters or markers.
+The value is always a number; markers and characters are converted
+to numbers.
*/
(int nargs, Lisp_Object *args))
{
- return arith_driver (Aadd, nargs, args);
+ EMACS_INT imin;
+ double dmin;
+ Lisp_Object *args_end = args + nargs;
+ int_or_double iod;
+
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ imin = iod.c.ival;
+ else
+ {
+ dmin = iod.c.dval;
+ goto min_floats;
+ }
+
+ while (args < args_end)
+ {
+ number_char_or_marker_to_int_or_double (*args++, &iod);
+ if (iod.int_p)
+ {
+ if (imin > iod.c.ival) imin = iod.c.ival;
+ }
+ else
+ {
+ dmin = (double) imin;
+ if (dmin > iod.c.dval) dmin = iod.c.dval;
+ goto min_floats;
+ }
+ }
+
+ return make_int (imin);
+
+ min_floats:
+ while (args < args_end)
+ {
+ double dval = number_char_or_marker_to_double (*args++);
+ if (dmin > dval) dmin = dval;
+ }
+ return make_float (dmin);
}
-DEFUN ("-", Fminus, 0, MANY, 0, /*
-Negate number or subtract numbers, characters or markers.
-With one arg, negates it. With more than one arg,
-subtracts all but the first from the first.
+DEFUN ("logand", Flogand, 0, MANY, 0, /*
+Return bitwise-and of all the arguments.
+Arguments may be integers, or markers or characters converted to integers.
*/
(int nargs, Lisp_Object *args))
{
- return arith_driver (Asub, nargs, args);
+ EMACS_INT bits = ~0;
+ Lisp_Object *args_end = args + nargs;
+
+ while (args < args_end)
+ bits &= integer_char_or_marker_to_int (*args++);
+
+ return make_int (bits);
}
-DEFUN ("*", Ftimes, 0, MANY, 0, /*
-Return product of any number of arguments.
-The arguments should all be numbers, characters or markers.
+DEFUN ("logior", Flogior, 0, MANY, 0, /*
+Return bitwise-or of all the arguments.
+Arguments may be integers, or markers or characters converted to integers.
*/
(int nargs, Lisp_Object *args))
{
- return arith_driver (Amult, nargs, args);
+ EMACS_INT bits = 0;
+ Lisp_Object *args_end = args + nargs;
+
+ while (args < args_end)
+ bits |= integer_char_or_marker_to_int (*args++);
+
+ return make_int (bits);
}
-DEFUN ("/", Fquo, 2, MANY, 0, /*
-Return first argument divided by all the remaining arguments.
-The arguments must be numbers, characters or markers.
+DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
+Return bitwise-exclusive-or of all the arguments.
+Arguments may be integers, or markers or characters converted to integers.
*/
(int nargs, Lisp_Object *args))
{
- return arith_driver (Adiv, nargs, args);
+ EMACS_INT bits = 0;
+ Lisp_Object *args_end = args + nargs;
+
+ while (args < args_end)
+ bits ^= integer_char_or_marker_to_int (*args++);
+
+ return make_int (bits);
+}
+
+DEFUN ("lognot", Flognot, 1, 1, 0, /*
+Return the bitwise complement of NUMBER.
+NUMBER may be an integer, marker or character converted to integer.
+*/
+ (number))
+{
+ return make_int (~ integer_char_or_marker_to_int (number));
}
DEFUN ("%", Frem, 2, 2, 0, /*
*/
(num1, num2))
{
- CHECK_INT_COERCE_CHAR_OR_MARKER (num1);
- CHECK_INT_COERCE_CHAR_OR_MARKER (num2);
+ int ival1 = integer_char_or_marker_to_int (num1);
+ int ival2 = integer_char_or_marker_to_int (num2);
- if (ZEROP (num2))
+ if (ival2 == 0)
Fsignal (Qarith_error, Qnil);
- return make_int (XINT (num1) % XINT (num2));
+ return make_int (ival1 % ival2);
}
/* Note, ANSI *requires* the presence of the fmod() library routine.
*/
(x, y))
{
- EMACS_INT i1, i2;
+ int_or_double iod1, iod2;
+ number_char_or_marker_to_int_or_double (x, &iod1);
+ number_char_or_marker_to_int_or_double (y, &iod2);
#ifdef LISP_FLOAT_TYPE
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
-
- if (FLOATP (x) || FLOATP (y))
+ if (!iod1.int_p || !iod2.int_p)
{
- double f1, f2;
-
- f1 = ((FLOATP (x)) ? float_data (XFLOAT (x)) : XINT (x));
- f2 = ((FLOATP (y)) ? float_data (XFLOAT (y)) : XINT (y));
- if (f2 == 0)
- Fsignal (Qarith_error, Qnil);
-
- f1 = fmod (f1, f2);
+ double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
+ double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
+ if (dval2 == 0) goto divide_by_zero;
+ dval1 = fmod (dval1, dval2);
/* If the "remainder" comes out with the wrong sign, fix it. */
- if (f2 < 0 ? f1 > 0 : f1 < 0)
- f1 += f2;
- return make_float (f1);
- }
-#else /* not LISP_FLOAT_TYPE */
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
-#endif /* not LISP_FLOAT_TYPE */
-
- i1 = XINT (x);
- i2 = XINT (y);
-
- if (i2 == 0)
- Fsignal (Qarith_error, Qnil);
-
- i1 %= i2;
-
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if (i2 < 0 ? i1 > 0 : i1 < 0)
- i1 += i2;
-
- return make_int (i1);
-}
-
+ if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
+ dval1 += dval2;
-DEFUN ("max", Fmax, 1, MANY, 0, /*
-Return largest of all the arguments.
-All arguments must be numbers, characters or markers.
-The value is always a number; markers and characters are converted
-to numbers.
-*/
- (int nargs, Lisp_Object *args))
-{
- return arith_driver (Amax, nargs, args);
-}
+ return make_float (dval1);
+ }
+#endif /* LISP_FLOAT_TYPE */
+ {
+ int ival;
+ if (iod2.c.ival == 0) goto divide_by_zero;
-DEFUN ("min", Fmin, 1, MANY, 0, /*
-Return smallest of all the arguments.
-All arguments must be numbers, characters or markers.
-The value is always a number; markers and characters are converted
-to numbers.
-*/
- (int nargs, Lisp_Object *args))
-{
- return arith_driver (Amin, nargs, args);
-}
+ ival = iod1.c.ival % iod2.c.ival;
-DEFUN ("logand", Flogand, 0, MANY, 0, /*
-Return bitwise-and of all the arguments.
-Arguments may be integers, or markers or characters converted to integers.
-*/
- (int nargs, Lisp_Object *args))
-{
- return arith_driver (Alogand, nargs, args);
-}
+ /* If the "remainder" comes out with the wrong sign, fix it. */
+ if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
+ ival += iod2.c.ival;
-DEFUN ("logior", Flogior, 0, MANY, 0, /*
-Return bitwise-or of all the arguments.
-Arguments may be integers, or markers or characters converted to integers.
-*/
- (int nargs, Lisp_Object *args))
-{
- return arith_driver (Alogior, nargs, args);
-}
+ return make_int (ival);
+ }
-DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
-Return bitwise-exclusive-or of all the arguments.
-Arguments may be integers, or markers or characters converted to integers.
-*/
- (int nargs, Lisp_Object *args))
-{
- return arith_driver (Alogxor, nargs, args);
+ divide_by_zero:
+ Fsignal (Qarith_error, Qnil);
+ return Qnil; /* not reached */
}
DEFUN ("ash", Fash, 2, 2, 0, /*
(value, count))
{
CHECK_INT_COERCE_CHAR (value);
- CHECK_INT (count);
+ CONCHECK_INT (count);
return make_int (XINT (count) > 0 ?
XINT (value) << XINT (count) :
(value, count))
{
CHECK_INT_COERCE_CHAR (value);
- CHECK_INT (count);
+ CONCHECK_INT (count);
return make_int (XINT (count) > 0 ?
XUINT (value) << XINT (count) :
}
DEFUN ("1+", Fadd1, 1, 1, 0, /*
-Return NUMBER plus one. NUMBER may be a number or a marker.
+Return NUMBER plus one. NUMBER may be a number, character or marker.
Markers and characters are converted to integers.
*/
(number))
{
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
+ retry:
+ if (INTP (number)) return make_int (XINT (number) + 1);
+ if (CHARP (number)) return make_int (XCHAR (number) + 1);
+ if (MARKERP (number)) return make_int (marker_position (number) + 1);
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (number))
- return make_float (1.0 + float_data (XFLOAT (number)));
+ if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
#endif /* LISP_FLOAT_TYPE */
- return make_int (XINT (number) + 1);
+ number = wrong_type_argument (Qnumber_char_or_marker_p, number);
+ goto retry;
}
DEFUN ("1-", Fsub1, 1, 1, 0, /*
-Return NUMBER minus one. NUMBER may be a number or a marker.
+Return NUMBER minus one. NUMBER may be a number, character or marker.
Markers and characters are converted to integers.
*/
(number))
{
- CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
+ retry:
+ if (INTP (number)) return make_int (XINT (number) - 1);
+ if (CHARP (number)) return make_int (XCHAR (number) - 1);
+ if (MARKERP (number)) return make_int (marker_position (number) - 1);
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (number))
- return make_float (-1.0 + (float_data (XFLOAT (number))));
+ if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
#endif /* LISP_FLOAT_TYPE */
- return make_int (XINT (number) - 1);
-}
-
-DEFUN ("lognot", Flognot, 1, 1, 0, /*
-Return the bitwise complement of NUMBER. NUMBER must be an integer.
-*/
- (number))
-{
- CHECK_INT (number);
- return make_int (~XINT (number));
+ number = wrong_type_argument (Qnumber_char_or_marker_p, number);
+ goto retry;
}
\f
disappear when no longer in use, i.e. when no longer GC-protected.
The basic idea is that we don't mark the elements during GC, but
wait for them to be marked elsewhere. If they're not marked, we
- remove them. This is analogous to weak hashtables; see the explanation
+ remove them. This is analogous to weak hash tables; see the explanation
there for more info. */
static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
}
static int
-weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct weak_list *w1 = XWEAK_LIST (o1);
- struct weak_list *w2 = XWEAK_LIST (o2);
+ struct weak_list *w1 = XWEAK_LIST (obj1);
+ struct weak_list *w2 = XWEAK_LIST (obj2);
return ((w1->type == w2->type) &&
internal_equal (w1->list, w2->list, depth + 1));
Lisp_Object rest2;
enum weak_list_type type = XWEAK_LIST (rest)->type;
- if (! ((*obj_marked_p) (rest)))
+ if (! obj_marked_p (rest))
/* The weak list is probably garbage. Ignore it. */
continue;
(either because of an external pointer or because of
a previous call to this function), and likewise for all
the rest of the elements in the list, so we can stop now. */
- if ((*obj_marked_p) (rest2))
+ if (obj_marked_p (rest2))
break;
elem = XCAR (rest2);
switch (type)
{
case WEAK_LIST_SIMPLE:
- if ((*obj_marked_p) (elem))
+ if (obj_marked_p (elem))
need_to_mark_cons = 1;
break;
need_to_mark_cons = 1;
need_to_mark_elem = 1;
}
- else if ((*obj_marked_p) (XCAR (elem)) &&
- (*obj_marked_p) (XCDR (elem)))
+ else if (obj_marked_p (XCAR (elem)) &&
+ obj_marked_p (XCDR (elem)))
{
need_to_mark_cons = 1;
/* We still need to mark elem, because it's
need_to_mark_cons = 1;
need_to_mark_elem = 1;
}
- else if ((*obj_marked_p) (XCAR (elem)))
+ else if (obj_marked_p (XCAR (elem)))
{
need_to_mark_cons = 1;
/* We still need to mark elem and XCDR (elem);
need_to_mark_cons = 1;
need_to_mark_elem = 1;
}
- else if ((*obj_marked_p) (XCDR (elem)))
+ else if (obj_marked_p (XCDR (elem)))
{
need_to_mark_cons = 1;
/* We still need to mark elem and XCAR (elem);
abort ();
}
- if (need_to_mark_elem && ! (*obj_marked_p) (elem))
+ if (need_to_mark_elem && ! obj_marked_p (elem))
{
- (*markobj) (elem);
+ markobj (elem);
did_mark = 1;
}
/* In case of imperfect list, need to mark the final cons
because we're not removing it */
- if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2))
+ if (!GC_NILP (rest2) && ! obj_marked_p (rest2))
{
- (markobj) (rest2);
+ markobj (rest2);
did_mark = 1;
}
}
!GC_NILP (rest);
rest = XWEAK_LIST (rest)->next_weak)
{
- if (! ((*obj_marked_p) (rest)))
+ if (! (obj_marked_p (rest)))
{
/* This weak list itself is garbage. Remove it from the list. */
if (GC_NILP (prev))
have been marked in finish_marking_weak_lists().
-- otherwise, it's not marked and should disappear.
*/
- if (!(*obj_marked_p) (rest2))
+ if (! obj_marked_p (rest2))
{
/* bye bye :-( */
if (GC_NILP (prev2))
"Attempt to set a constant symbol", Qerror);
deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
"Invalid read syntax", Qerror);
+
+ /* Generated by list traversal macros */
deferror (&Qmalformed_list, "malformed-list",
"Malformed list", Qerror);
deferror (&Qmalformed_property_list, "malformed-property-list",
- "Malformed property list", Qerror);
+ "Malformed property list", Qmalformed_list);
deferror (&Qcircular_list, "circular-list",
"Circular list", Qerror);
deferror (&Qcircular_property_list, "circular-property-list",
- "Circular property list", Qerror);
+ "Circular property list", Qcircular_list);
+
deferror (&Qinvalid_function, "invalid-function", "Invalid function",
Qerror);
deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
defsymbol (&Qbitp, "bitp");
defsymbol (&Qbit_vectorp, "bit-vector-p");
defsymbol (&Qvectorp, "vectorp");
- defsymbol (&Qcompiled_functionp, "compiled-function-p");
defsymbol (&Qchar_or_string_p, "char-or-string-p");
defsymbol (&Qmarkerp, "markerp");
defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
DEFSUBR (Feq);
DEFSUBR (Fold_eq);
DEFSUBR (Fnull);
+ Ffset (intern ("not"), intern ("null"));
DEFSUBR (Flistp);
DEFSUBR (Fnlistp);
DEFSUBR (Ftrue_list_p);
DEFSUBR (Fsubr_min_args);
DEFSUBR (Fsubr_max_args);
DEFSUBR (Fsubr_interactive);
- DEFSUBR (Fcompiled_function_p);
DEFSUBR (Ftype_of);
DEFSUBR (Fcar);
DEFSUBR (Fcdr);
DEFSUBR (Faref);
DEFSUBR (Faset);
- DEFSUBR (Fcompiled_function_instructions);
- DEFSUBR (Fcompiled_function_constants);
- DEFSUBR (Fcompiled_function_stack_depth);
- DEFSUBR (Fcompiled_function_arglist);
- DEFSUBR (Fcompiled_function_interactive);
- DEFSUBR (Fcompiled_function_doc_string);
- DEFSUBR (Fcompiled_function_domain);
-#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
- DEFSUBR (Fcompiled_function_annotation);
-#endif
-
DEFSUBR (Fnumber_to_string);
DEFSUBR (Fstring_to_number);
DEFSUBR (Feqlsign);
#ifdef DEBUG_XEMACS
DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
-If non-nil, note when your code may be suffering from char-int confoundance.
+If non-zero, note when your code may be suffering from char-int confoundance.
That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
-etc. where a int and a char with the same value are being compared,
+etc. where an int and a char with the same value are being compared,
it will issue a notice on stderr to this effect, along with a backtrace.
In such situations, the result would be different in XEmacs 19 versus
XEmacs 20, and you probably don't want this.
#include <config.h>
#include "lisp.h"
#include "sysfile.h"
+#include "buffer.h"
#include <errno.h>
#ifndef HAVE_DATABASE
Lisp_Object Qdbm;
#endif /* HAVE_DBM */
-Lisp_Object Qdatabasep;
+#ifdef MULE
+/* #### The following should be settable on a per-database level.
+ But the whole coding-system infrastructure should be rewritten someday.
+ We really need coding-system aliases. -- martin */
+Lisp_Object Vdatabase_coding_system;
+#endif
-typedef enum { DB_DBM, DB_BERKELEY, DB_IS_UNKNOWN } XEMACS_DB_TYPE;
+Lisp_Object Qdatabasep;
struct Lisp_Database;
+typedef struct Lisp_Database Lisp_Database;
typedef struct
{
- Lisp_Object (*get_subtype) (struct Lisp_Database *);
- Lisp_Object (*get_type) (struct Lisp_Database *);
- Lisp_Object (*get) (struct Lisp_Database *, Lisp_Object);
- int (*put) (struct Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
- int (*rem) (struct Lisp_Database *, Lisp_Object);
- void (*map) (struct Lisp_Database *, Lisp_Object);
- void (*close) (struct Lisp_Database *);
- Lisp_Object (*last_error) (struct Lisp_Database *);
+ Lisp_Object (*get_subtype) (Lisp_Database *);
+ Lisp_Object (*get_type) (Lisp_Database *);
+ Lisp_Object (*get) (Lisp_Database *, Lisp_Object);
+ int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object);
+ int (*rem) (Lisp_Database *, Lisp_Object);
+ void (*map) (Lisp_Database *, Lisp_Object);
+ void (*close) (Lisp_Database *);
+ Lisp_Object (*last_error) (Lisp_Database *);
} DB_FUNCS;
struct Lisp_Database
{
struct lcrecord_header header;
Lisp_Object fname;
- XEMACS_DB_TYPE type;
int mode;
int access_;
int dberrno;
#endif
};
-#define XDATABASE(x) XRECORD (x, database, struct Lisp_Database)
+#define XDATABASE(x) XRECORD (x, database, Lisp_Database)
#define XSETDATABASE(x, p) XSETRECORD (x, p, database)
#define DATABASEP(x) RECORDP (x, database)
#define GC_DATABASEP(x) GC_RECORDP (x, database)
} while (0)
-static struct Lisp_Database *
+static Lisp_Database *
allocate_database (void)
{
- struct Lisp_Database *db =
- alloc_lcrecord_type (struct Lisp_Database, lrecord_database);
+ Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, lrecord_database);
db->fname = Qnil;
db->live_p = 0;
db->access_ = 0;
db->mode = 0;
db->dberrno = 0;
- db->type = DB_IS_UNKNOWN;
#ifdef MULE
db->coding_system = Fget_coding_system (Qbinary);
#endif
static Lisp_Object
mark_database (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
- struct Lisp_Database *db = XDATABASE (obj);
+ Lisp_Database *db = XDATABASE (obj);
- ((markobj) (db->fname));
+ markobj (db->fname);
return Qnil;
}
print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
char buf[64];
- struct Lisp_Database *db = XDATABASE (obj);
+ Lisp_Database *db = XDATABASE (obj);
if (print_readably)
error ("printing unreadable object #<database 0x%x>", db->header.uid);
static void
finalize_database (void *header, int for_disksave)
{
- struct Lisp_Database *db = (struct Lisp_Database *) header;
+ Lisp_Database *db = (Lisp_Database *) header;
if (for_disksave)
{
Lisp_Object obj;
- XSETOBJ (obj, Lisp_Type_Record, (void *) db);
+ XSETDATABASE (obj, db);
signal_simple_error
("Can't dump an emacs containing database objects", obj);
DEFINE_LRECORD_IMPLEMENTATION ("database", database,
mark_database, print_database,
finalize_database, 0, 0,
- struct Lisp_Database);
+ Lisp_Database);
DEFUN ("close-database", Fclose_database, 1, 1, 0, /*
Close database DATABASE.
*/
(database))
{
- struct Lisp_Database *db;
+ Lisp_Database *db;
CHECK_LIVE_DATABASE (database);
db = XDATABASE (database);
db->funcs->close (db);
#ifdef HAVE_DBM
static void
-dbm_map (struct Lisp_Database *db, Lisp_Object func)
+dbm_map (Lisp_Database *db, Lisp_Object func)
{
datum keydatum, valdatum;
Lisp_Object key, val;
}
static Lisp_Object
-dbm_get (struct Lisp_Database *db, Lisp_Object key)
+dbm_get (Lisp_Database *db, Lisp_Object key)
{
datum keydatum, valdatum;
}
static int
-dbm_put (struct Lisp_Database *db,
+dbm_put (Lisp_Database *db,
Lisp_Object key, Lisp_Object val, Lisp_Object replace)
{
datum keydatum, valdatum;
}
static int
-dbm_remove (struct Lisp_Database *db, Lisp_Object key)
+dbm_remove (Lisp_Database *db, Lisp_Object key)
{
datum keydatum;
}
static Lisp_Object
-dbm_type (struct Lisp_Database *db)
+dbm_type (Lisp_Database *db)
{
return Qdbm;
}
static Lisp_Object
-dbm_subtype (struct Lisp_Database *db)
+dbm_subtype (Lisp_Database *db)
{
return Qnil;
}
static Lisp_Object
-dbm_lasterr (struct Lisp_Database *db)
+dbm_lasterr (Lisp_Database *db)
{
return lisp_strerror (db->dberrno);
}
static void
-dbm_closeit (struct Lisp_Database *db)
+dbm_closeit (Lisp_Database *db)
{
if (db->dbm_handle)
{
#ifdef HAVE_BERKELEY_DB
static Lisp_Object
-berkdb_type (struct Lisp_Database *db)
+berkdb_type (Lisp_Database *db)
{
return Qberkeley_db;
}
static Lisp_Object
-berkdb_subtype (struct Lisp_Database *db)
+berkdb_subtype (Lisp_Database *db)
{
if (!db->db_handle)
return Qnil;
}
static Lisp_Object
-berkdb_lasterr (struct Lisp_Database *db)
+berkdb_lasterr (Lisp_Database *db)
{
return lisp_strerror (db->dberrno);
}
static Lisp_Object
-berkdb_get (struct Lisp_Database *db, Lisp_Object key)
+berkdb_get (Lisp_Database *db, Lisp_Object key)
{
- /* #### Needs mule-izing */
DBT keydatum, valdatum;
int status = 0;
-#if DB_VERSION_MAJOR == 2
- /* Always initialize keydatum, valdatum. */
+ /* DB Version 2 requires DBT's to be zeroed before use. */
xzero (keydatum);
xzero (valdatum);
-#endif /* DV_VERSION_MAJOR = 2 */
keydatum.data = XSTRING_DATA (key);
keydatum.size = XSTRING_LENGTH (key);
#endif /* DB_VERSION_MAJOR */
if (!status)
+ /* #### Not mule-ized! will crash! */
return make_string ((Bufbyte *) valdatum.data, valdatum.size);
#if DB_VERSION_MAJOR == 1
}
static int
-berkdb_put (struct Lisp_Database *db,
+berkdb_put (Lisp_Database *db,
Lisp_Object key,
Lisp_Object val,
Lisp_Object replace)
DBT keydatum, valdatum;
int status = 0;
-#if DB_VERSION_MAJOR == 2
- /* Always initalize keydatum, valdatum. */
+ /* DB Version 2 requires DBT's to be zeroed before use. */
xzero (keydatum);
xzero (valdatum);
-#endif /* DV_VERSION_MAJOR = 2 */
keydatum.data = XSTRING_DATA (key);
keydatum.size = XSTRING_LENGTH (key);
}
static int
-berkdb_remove (struct Lisp_Database *db, Lisp_Object key)
+berkdb_remove (Lisp_Database *db, Lisp_Object key)
{
DBT keydatum;
int status;
-#if DB_VERSION_MAJOR == 2
- /* Always initialize keydatum. */
+ /* DB Version 2 requires DBT's to be zeroed before use. */
xzero (keydatum);
-#endif /* DV_VERSION_MAJOR = 2 */
keydatum.data = XSTRING_DATA (key);
keydatum.size = XSTRING_LENGTH (key);
}
static void
-berkdb_map (struct Lisp_Database *db, Lisp_Object func)
+berkdb_map (Lisp_Database *db, Lisp_Object func)
{
DBT keydatum, valdatum;
Lisp_Object key, val;
DB *dbp = db->db_handle;
int status;
+ xzero (keydatum);
+ xzero (valdatum);
+
#if DB_VERSION_MAJOR == 1
for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST);
status == 0;
}
#else
DBC *dbcp;
- /* Initialize the key/data pair so the flags aren't set. */
- xzero (keydatum);
- xzero (valdatum);
status = dbp->cursor (dbp, NULL, &dbcp);
for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST);
}
static void
-berkdb_close (struct Lisp_Database *db)
+berkdb_close (Lisp_Database *db)
{
if (db->db_handle)
{
/* This function can GC */
int modemask;
int accessmask = 0;
- struct Lisp_Database *db = NULL;
+ Lisp_Database *db = NULL;
char *filename;
struct gcpro gcpro1, gcpro2;
GCPRO2 (file, access_);
file = Fexpand_file_name (file, Qnil);
UNGCPRO;
- filename = (char *) XSTRING_DATA (file);
+
+ GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename);
if (NILP (access_))
{
db = allocate_database ();
db->dbm_handle = dbase;
- db->type = DB_DBM;
db->funcs = &ndbm_func_block;
goto db_done;
}
db = allocate_database ();
db->db_handle = dbase;
- db->type = DB_BERKELEY;
db->funcs = &berk_func_block;
goto db_done;
}
CHECK_STRING (key);
CHECK_STRING (value);
{
- struct Lisp_Database *db = XDATABASE (database);
+ Lisp_Database *db = XDATABASE (database);
int status = db->funcs->put (db, key, value, replace);
return status ? Qt : Qnil;
}
CHECK_LIVE_DATABASE (database);
CHECK_STRING (key);
{
- struct Lisp_Database *db = XDATABASE (database);
+ Lisp_Database *db = XDATABASE (database);
int status = db->funcs->rem (db, key);
return status ? Qt : Qnil;
}
CHECK_LIVE_DATABASE (database);
CHECK_STRING (key);
{
- struct Lisp_Database *db = XDATABASE (database);
+ Lisp_Database *db = XDATABASE (database);
Lisp_Object retval = db->funcs->get (db, key);
return NILP (retval) ? default_ : retval;
}
#ifdef HAVE_BERKELEY_DB
Fprovide (Qberkeley_db);
#endif
+
+#if 0 /* #### implement me! */
+#ifdef MULE
+ DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /*
+Coding system used to convert data in database files.
+*/ );
+ Vdatabase_coding_system = Qnil;
+#endif
+#endif /* 0 */
}
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; \
}
#ifdef HAVE_X_WINDOWS
balloon-x.o: $(LISP_H) balloon_help.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h xintrinsic.h
console-x.o: $(LISP_H) conslots.h console-x.h console.h lisp-disunion.h lisp-union.h lrecord.h process.h redisplay.h symeval.h symsinit.h xintrinsic.h
-device-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmu.h
-dialog-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h EmacsShell.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h
+device-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h elhash.h events.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmu.h
+dialog-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h
frame-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h EmacsShell.h ExternalShell.h buffer.h bufslots.h conslots.h console-x.h console.h device.h dragdrop.h events-mod.h events.h extents.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h xintrinsicp.h xmprimitivep.h xmu.h
glyphs-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h bitmaps.h buffer.h bufslots.h conslots.h console-x.h console.h device.h file-coding.h frame.h frameslots.h glyphs-x.h glyphs.h imgproc.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h xintrinsic.h xmu.h
gui-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h xintrinsic.h
input-method-xfs.o: $(LISP_H) EmacsFrame.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h
input-method-xlib.o: $(LISP_H) EmacsFrame.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h
-menubar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h EmacsShell.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h
+menubar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h
objects-x.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h specifier.h symeval.h symsinit.h xintrinsic.h
redisplay-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h conslots.h console-x.h console.h debug.h device.h faces.h file-coding.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-ccl.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysproc.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmprimitivep.h
-scrollbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h conslots.h console-x.h console.h device.h frame.h frameslots.h glyphs-x.h glyphs.h gui-x.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h
-toolbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h buffer.h bufslots.h conslots.h console-x.h console.h device.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmprimitivep.h
+scrollbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h conslots.h console-x.h console.h device.h frame.h frameslots.h glyphs-x.h glyphs.h gui-x.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h
+toolbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h conslots.h console-x.h console.h device.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h xintrinsicp.h xmprimitivep.h
#endif
#ifdef HAVE_DATABASE
-database.o: $(LISP_H) database.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h
+database.o: $(LISP_H) buffer.h bufslots.h database.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfile.h
#endif
#ifdef MULE
mule-canna.o: $(LISP_H) buffer.h bufslots.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h
EmacsShell-sub.o: EmacsShell.h EmacsShellP.h config.h xintrinsic.h xintrinsicp.h
EmacsShell.o: EmacsShell.h ExternalShell.h config.h xintrinsicp.h
abbrev.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h symeval.h symsinit.h syntax.h window.h winslots.h
-alloc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h conslots.h console.h device.h elhash.h events.h extents.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h puresize.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h systime.h toolbar.h window.h winslots.h
+alloc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h conslots.h console.h device.h elhash.h events.h extents.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h puresize-adjust.h puresize.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h systime.h toolbar.h window.h winslots.h
alloca.o: config.h
balloon_help.o: balloon_help.h config.h xintrinsic.h
blocktype.o: $(LISP_H) blocktype.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
buffer.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syntax.h sysdep.h sysfile.h toolbar.h window.h winslots.h
-bytecode.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
+bytecode.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h syntax.h
callint.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h events.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h symeval.h symsinit.h systime.h window.h winslots.h
-callproc.o: $(LISP_H) buffer.h bufslots.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h nt.h paths.h process.h redisplay.h scrollbar.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h window.h winslots.h
-casefiddle.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
+callproc.o: $(LISP_H) buffer.h bufslots.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h nt.h process.h redisplay.h scrollbar.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h window.h winslots.h
+casefiddle.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
casetab.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h
-chartab.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
+chartab.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
cm.o: $(LISP_H) conslots.h console-tty.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h
-cmdloop.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h macros.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
+cmdloop.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
cmds.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
console-stream.o: $(LISP_H) conslots.h console-stream.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h
-console-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h faces.h file-coding.h frame.h frameslots.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systty.h toolbar.h
+console-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h faces.h file-coding.h frame.h frameslots.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systty.h toolbar.h
console.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h
data.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfloat.h syssignal.h
debug.o: $(LISP_H) bytecode.h debug.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
device-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h events.h faces.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h
device.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h events.h faces.h frame.h frameslots.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h toolbar.h window.h winslots.h
+dgif_lib.o: gifrlib.h
dialog.o: $(LISP_H) conslots.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h
-dired.o: $(LISP_H) buffer.h bufslots.h commands.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h opaque.h regex.h symeval.h symsinit.h sysdir.h sysfile.h
+dired.o: $(LISP_H) buffer.h bufslots.h commands.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h opaque.h regex.h symeval.h symsinit.h sysdir.h sysfile.h syspwd.h systime.h
dll.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysdll.h
doc.o: $(LISP_H) buffer.h bufslots.h bytecode.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfile.h
doprnt.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h
dragdrop.o: $(LISP_H) dragdrop.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
dynarr.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
ecrt0.o: config.h
-editfns.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syspwd.h systime.h toolbar.h window.h winslots.h
+editfns.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syspwd.h systime.h toolbar.h window.h winslots.h
eldap.o: $(LISP_H) eldap.h lisp-disunion.h lisp-union.h lrecord.h opaque.h symeval.h symsinit.h sysdep.h
-elhash.o: $(LISP_H) bytecode.h elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
-emacs.o: $(LISP_H) backtrace.h buffer.h bufslots.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h paths.h process.h symeval.h symsinit.h sysdep.h sysdll.h sysfile.h syssignal.h systime.h systty.h
+elhash.o: $(LISP_H) bytecode.h elhash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
+emacs.o: $(LISP_H) backtrace.h buffer.h bufslots.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h paths.h process.h redisplay.h symeval.h symsinit.h sysdep.h sysdll.h sysfile.h syssignal.h systime.h systty.h
eval.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h
-event-Xt.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h blocktype.h buffer.h bufslots.h commands.h conslots.h console-tty.h console-x.h console.h device.h dragdrop.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h offix-types.h offix.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h toolbar.h xintrinsic.h xintrinsicp.h
+event-Xt.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h blocktype.h buffer.h bufslots.h conslots.h console-tty.h console-x.h console.h device.h dragdrop.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h offix-types.h offix.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h toolbar.h xintrinsic.h xintrinsicp.h
event-stream.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h blocktype.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h gui-x.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h lstream.h macros.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systime.h toolbar.h window.h winslots.h xintrinsic.h
event-tty.o: $(LISP_H) conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h process.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h
event-unixoid.o: $(LISP_H) conslots.h console-stream.h console-tty.h console.h device.h events.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h process.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h
events.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console-x.h console.h device.h events-mod.h events.h extents.h frame.h frameslots.h glyphs.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h xintrinsic.h
-extents.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h hash.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h
-faces.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h hash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
+extents.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h
+faces.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
file-coding.o: $(LISP_H) buffer.h bufslots.h elhash.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-ccl.h mule-charset.h symeval.h symsinit.h
fileio.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h ndir.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysdir.h sysfile.h sysproc.h syspwd.h systime.h toolbar.h window.h winslots.h
filelock.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h paths.h symeval.h symsinit.h sysdir.h sysfile.h syspwd.h syssignal.h
filemode.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h
floatfns.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfloat.h syssignal.h
-fns.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h
+fns.o: $(LISP_H) buffer.h bufslots.h bytecode.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h
font-lock.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
frame-tty.o: $(LISP_H) conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systime.h systty.h toolbar.h
-frame.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h extents.h faces.h frame.h frameslots.h glyphs.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h systime.h toolbar.h window.h winslots.h
+frame.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h extents.h faces.h frame.h frameslots.h glyphs.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
free-hook.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
general.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
getloadavg.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h
-glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h file-coding.h frame.h frameslots.h glyphs.h imgproc.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h
+gif_io.o: gifrlib.h
+glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h file-coding.h frame.h frameslots.h gifrlib.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h
glyphs.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h faces.h frame.h frameslots.h glyphs.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
gmalloc.o: config.h getpagesize.h
gpmevent.o: $(LISP_H) conslots.h console-tty.h console.h device.h events-mod.h events.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h
gui.o: $(LISP_H) bytecode.h gui.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
-hash.o: $(LISP_H) elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
+hash.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
hftctl.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
hpplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
imgproc.o: $(LISP_H) imgproc.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
input-method-motif.o: $(LISP_H) EmacsFrame.h conslots.h console-x.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h xintrinsic.h
insdel.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h
intl.o: $(LISP_H) bytecode.h conslots.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
-keymap.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h conslots.h console.h device.h elhash.h events-mod.h events.h frame.h frameslots.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
+keymap.o: $(LISP_H) buffer.h bufslots.h bytecode.h conslots.h console.h device.h elhash.h events-mod.h events.h frame.h frameslots.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
libsst.o: $(LISP_H) libsst.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
-line-number.o: $(LISP_H) buffer.h bufslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h
+line-number.o: $(LISP_H) buffer.h bufslots.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h
linuxplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h syssignal.h
-lread.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h paths.h symeval.h symsinit.h sysfile.h sysfloat.h
+lread.o: $(LISP_H) buffer.h bufslots.h bytecode.h elhash.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h symeval.h symsinit.h sysfile.h sysfloat.h
lstream.o: $(LISP_H) buffer.h bufslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h sysfile.h
macros.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h keymap.h lisp-disunion.h lisp-union.h lrecord.h macros.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
malloc.o: config.h getpagesize.h
md5.o: $(LISP_H) buffer.h bufslots.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h
menubar.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h frame.h frameslots.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
minibuf.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-stream.h console.h device.h events.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h
-nas.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h
+nas.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h
nt.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h nt.h ntheap.h symeval.h symsinit.h sysproc.h syssignal.h systime.h
ntheap.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h ntheap.h symeval.h symsinit.h
ntplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h
opaque.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h opaque.h symeval.h symsinit.h
print.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h conslots.h console-stream.h console-tty.h console.h device.h extents.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h syssignal.h systty.h toolbar.h
process-nt.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h process.h procimpl.h symeval.h symsinit.h sysdep.h
-process-unix.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h
-process.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h
-profile.o: $(LISP_H) backtrace.h bytecode.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h systime.h
+process-unix.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h
+process.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h
+profile.o: $(LISP_H) backtrace.h bytecode.h elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h systime.h
pure.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h puresize-adjust.h puresize.h symeval.h symsinit.h
ralloc.o: $(LISP_H) getpagesize.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
rangetab.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h rangetab.h symeval.h symsinit.h
realpath.o: config.h
-redisplay-output.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h toolbar.h window.h winslots.h
+redisplay-output.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
redisplay-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console.h device.h events.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-tty.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h
-redisplay.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-tty.h console.h debug.h device.h extents.h faces.h file-coding.h frame.h frameslots.h glyphs.h gui.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h objects.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h window.h winslots.h
+redisplay.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-tty.h console.h debug.h device.h elhash.h extents.h faces.h file-coding.h frame.h frameslots.h glyphs.h gui.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h objects.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h window.h winslots.h
regex.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h regex.h symeval.h symsinit.h syntax.h
scrollbar.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
-search.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h regex.h symeval.h symsinit.h syntax.h
+search.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h regex.h symeval.h symsinit.h syntax.h
sgiplay.o: $(LISP_H) libst.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
sheap.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h sheap-adjust.h symeval.h symsinit.h
signal.o: $(LISP_H) conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h toolbar.h
-sound.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h symeval.h symsinit.h sysdep.h xintrinsic.h
+sound.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h symeval.h symsinit.h sysdep.h xintrinsic.h
specifier.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
strcat.o: config.h
strcmp.o: config.h
sunplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h
sunpro.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
symbols.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h
-syntax.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
+syntax.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h
sysdep.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h ntheap.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysdir.h sysfile.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h
sysdll.o: config.h sysdll.h
termcap.o: $(LISP_H) conslots.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h
unexhp9k3.o: config.h sysdep.h
unexhp9k800.o: config.h
unexmips.o: config.h getpagesize.h
-unexnt.o: ntheap.h
+unexnt.o: config.h ntheap.h
unexsunos4.o: config.h
vm-limit.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h mem-limits.h symeval.h symsinit.h
-widget.o: $(LISP_H) buffer.h bufslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h
-window.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
+widget.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h
+window.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h
xgccache.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h xgccache.h
xmu.o: config.h
xselect.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h xintrinsic.h
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);
}
{
Lisp_Object obj = largs[spec->argnum - 1];
if (CHARP (obj))
- CHECK_INT_COERCE_CHAR (obj);
+ obj = make_int (XCHAR (obj));
if (!INT_OR_FLOATP (obj))
{
error ("format specifier %%%c doesn't match argument type",
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_ */
#include "commands.h"
#include "console.h"
#include "process.h"
+#include "redisplay.h"
#include "sysdep.h"
-#include <setjmp.h>
#include "syssignal.h" /* Always include before systty.h */
#include "systty.h"
#include "sysfile.h"
#include "systime.h"
+#ifdef QUANTIFY
+#include <quantify.h>
+#endif
+
#ifdef HAVE_SHLIB
#include "sysdll.h"
#endif
static void sort_args (int argc, char **argv);
-extern int always_gc; /* hack */
-
Lisp_Object Qkill_emacs_hook;
Lisp_Object Qsave_buffers_kill_emacs;
#endif
#if defined (MULE) && defined (MSDOS) && defined (EMX)
-/* Setup all of files be input/output'ed with binary translation mdoe. */
+/* Setup all of files be input/output'ed with binary translation mode. */
asm (" .text");
asm ("L_setbinmode:");
asm (" movl $1, __fmode_bin");
/* Make stack traces always identify version + configuration */
#define main_1 STACK_TRACE_EYE_CATCHER
-static DOESNT_RETURN
+/* This function is not static, so that the compiler is less likely to
+ inline it, which would make it not show up in stack traces. */
+DECLARE_DOESNT_RETURN (main_1 (int, char **, char **, int));
+DOESNT_RETURN
main_1 (int argc, char **argv, char **envp, int restart)
{
char stack_bottom_variable;
syms_of_elhash ();
syms_of_emacs ();
syms_of_eval ();
+#ifdef HAVE_X_WINDOWS
+ syms_of_event_Xt ();
+#endif
#ifdef HAVE_DRAGNDROP
syms_of_dragdrop ();
#endif
syms_of_device_tty ();
syms_of_objects_tty ();
#endif
+
#ifdef HAVE_X_WINDOWS
syms_of_device_x ();
#ifdef HAVE_DIALOGS
syms_of_dialog_x ();
#endif
- syms_of_event_Xt ();
syms_of_frame_x ();
syms_of_glyphs_x ();
syms_of_objects_x ();
#ifdef HAVE_MS_WINDOWS
syms_of_console_mswindows ();
syms_of_device_mswindows ();
- syms_of_event_mswindows ();
syms_of_frame_mswindows ();
syms_of_objects_mswindows ();
syms_of_select_mswindows ();
SYMS_MACHINE;
#endif
-#ifdef EMACS_BTL
- syms_of_btl ();
-#endif
-
/*
#if defined (GNU_MALLOC) && \
defined (ERROR_CHECK_MALLOC) && \
structure_type_create_chartab ();
structure_type_create_faces ();
structure_type_create_rangetab ();
- structure_type_create_hashtable ();
+ structure_type_create_hash_table ();
/* Now initialize the image instantiator formats and associated symbols.
Other than the first function below, the functions may
#if defined (HAVE_MS_WINDOWS) && !defined(HAVE_MSG_SELECT)
lstream_type_create_mswindows_selectable ();
#endif
-
+
/* Initialize processes implementation.
The functions may make exactly the following function/macro calls:
vars_of_elhash ();
vars_of_emacs ();
vars_of_eval ();
+
+#ifdef HAVE_X_WINDOWS
+ vars_of_event_Xt ();
+#endif
+#if defined(HAVE_TTY) && (defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS))
+ vars_of_event_tty ();
+#endif
+#ifdef HAVE_MS_WINDOWS
+ vars_of_event_mswindows ();
+#endif
vars_of_event_stream ();
+
vars_of_events ();
vars_of_extents ();
vars_of_faces ();
#ifdef HAVE_TTY
vars_of_console_tty ();
- vars_of_event_tty ();
vars_of_frame_tty ();
vars_of_objects_tty ();
#endif
#ifdef HAVE_DIALOGS
vars_of_dialog_x ();
#endif
- vars_of_event_Xt ();
vars_of_frame_x ();
vars_of_glyphs_x ();
#ifdef HAVE_MENUBARS
#ifdef HAVE_MS_WINDOWS
vars_of_device_mswindows ();
vars_of_console_mswindows ();
- vars_of_event_mswindows ();
vars_of_frame_mswindows ();
vars_of_objects_mswindows ();
vars_of_select_mswindows ();
/* Calls Fmake_range_table(). */
complex_vars_of_search ();
- /* Calls make_lisp_hashtable(). */
+ /* Calls make_lisp_hash_table(). */
complex_vars_of_extents ();
- /* Depends on hashtables and specifiers. */
+ /* Depends on hash tables and specifiers. */
complex_vars_of_faces ();
#ifdef MULE
- /* These two depend on hashtables and various variables declared
+ /* These two depend on hash tables and various variables declared
earlier. The second may also depend on the first. */
complex_vars_of_mule_charset ();
#endif
complex_vars_of_emacs ();
/* This creates a couple of basic keymaps and depends on Lisp
- hashtables and Ffset() (both of which depend on some variables
+ hash tables and Ffset() (both of which depend on some variables
initialized in the vars_of_*() section) and possibly other
stuff. */
complex_vars_of_keymap ();
- /* Calls Fmake_hashtable() and creates a keymap */
+
+ /* Calls make_lisp_hash_table() and creates a keymap */
complex_vars_of_event_stream ();
- if (always_gc) /* purification debugging hack */
- garbage_collect_1 ();
+#ifdef ERROR_CHECK_GC
+ {
+ extern int always_gc;
+ if (always_gc) /* purification debugging hack */
+ garbage_collect_1 ();
+ }
+#endif
}
/* CONGRATULATIONS!!! We have successfully initialized the Lisp
#ifdef WINDOWSNT
/*
* For Win32, call init_environment() now, so that environment/registry
- * variables will be properly entered into Vprocess_envonment.
+ * variables will be properly entered into Vprocess_environment.
*/
init_environment();
#endif
char *buf = (char *)alloca (XSTRING_LENGTH (Vinvocation_directory)
+ XSTRING_LENGTH (Vinvocation_name)
+ 2);
- sprintf (buf, "%s/%s", XSTRING_DATA(Vinvocation_directory),
- XSTRING_DATA(Vinvocation_name));
+ sprintf (buf, "%s/%s", XSTRING_DATA (Vinvocation_directory),
+ XSTRING_DATA (Vinvocation_name));
/* All we can do is cry if an error happens, so ignore it. */
- (void)dll_init(buf);
+ (void) dll_init (buf);
}
#endif
static void
sort_args (int argc, char **argv)
{
- char **new = xnew_array (char *, argc);
+ char **new_argv = xnew_array (char *, argc);
/* For each element of argv,
the corresponding element of options is:
0 for an option that takes no arguments,
}
}
- /* Copy the arguments, in order of decreasing priority, to NEW. */
- new[0] = argv[0];
+ /* Copy the arguments, in order of decreasing priority, to NEW_ARGV. */
+ new_argv[0] = argv[0];
while (to < argc)
{
int best = -1;
if (best < 0)
abort ();
- /* Copy the highest priority remaining option, with its args, to NEW. */
- new[to++] = argv[best];
+ /* Copy the highest priority remaining option, with its args, to NEW_ARGV. */
+ new_argv[to++] = argv[best];
for (i = 0; i < options[best]; i++)
- new[to++] = argv[best + i + 1];
+ new_argv[to++] = argv[best + i + 1];
/* Clear out this option in ARGV. */
argv[best] = 0;
argv[best + i + 1] = 0;
}
- memcpy (argv, new, sizeof (char *) * argc);
+ memcpy (argv, new_argv, sizeof (char *) * argc);
+ xfree (new_argv);
+ xfree (options);
+ xfree (priority);
}
static JMP_BUF run_temacs_catch;
a dumped version in case you want to rerun it. This function is most
useful when used as part of the `make all-elc' command. --ben]
This will "restart" emacs with the specified command-line arguments.
- */
+
+ Martin thinks this function is most useful when using debugging
+ tools like Purify or tcov that get confused by XEmacs' dumping. */
(int nargs, Lisp_Object *args))
{
int ac;
unbind_to (0, Qnil); /* this closes loadup.el */
purify_flag = 0;
run_temacs_argc = nargs + 1;
+#if 0
#ifdef REPORT_PURE_USAGE
report_pure_usage (1, 0);
#else
report_pure_usage (0, 0);
#endif
+#endif /* 0 */
LONGJMP (run_temacs_catch, 1);
return Qnil; /* not reached; warning suppression */
}
int volatile vol_argc = argc;
char ** volatile vol_argv = argv;
char ** volatile vol_envp = envp;
- /* This is hairy. We need to compute where the XEmacs binary was invoked */
- /* from because temacs initialization requires it to find the lisp */
- /* directories. The code that recomputes the path is guarded by the */
- /* restarted flag. There are three possible paths I've found so far */
- /* through this: */
- /* temacs -- When running temacs for basic build stuff, the first main_1 */
- /* will be the only one invoked. It must compute the path else there */
- /* will be a very ugly bomb in startup.el (can't find obvious location */
- /* for doc-directory data-directory, etc.). */
- /* temacs w/ run-temacs on the command line -- This is run to bytecompile */
- /* all the out of date dumped lisp. It will execute both of the main_1 */
- /* calls and the second one must not touch the first computation because */
- /* argc/argv are hosed the second time through. */
- /* xemacs -- Only the second main_1 is executed. The invocation path must */
- /* computed but this only matters when running in place or when running */
- /* as a login shell. */
- /* As a bonus for straightening this out, XEmacs can now be run in place */
- /* as a login shell. This never used to work. */
- /* As another bonus, we can now guarantee that */
- /* (concat invocation-directory invocation-name) contains the filename */
- /* of the XEmacs binary we are running. This can now be used in a */
- /* definite test for out of date dumped files. -slb */
+ /* This is hairy. We need to compute where the XEmacs binary was invoked
+ from because temacs initialization requires it to find the lisp
+ directories. The code that recomputes the path is guarded by the
+ restarted flag. There are three possible paths I've found so far
+ through this:
+
+ temacs -- When running temacs for basic build stuff, the first main_1
+ will be the only one invoked. It must compute the path else there
+ will be a very ugly bomb in startup.el (can't find obvious location
+ for doc-directory data-directory, etc.).
+
+ temacs w/ run-temacs on the command line -- This is run to bytecompile
+ all the out of date dumped lisp. It will execute both of the main_1
+ calls and the second one must not touch the first computation because
+ argc/argv are hosed the second time through.
+
+ xemacs -- Only the second main_1 is executed. The invocation path must
+ computed but this only matters when running in place or when running
+ as a login shell.
+
+ As a bonus for straightening this out, XEmacs can now be run in place
+ as a login shell. This never used to work.
+
+ As another bonus, we can now guarantee that
+ (concat invocation-directory invocation-name) contains the filename
+ of the XEmacs binary we are running. This can now be used in a
+ definite test for out of date dumped files. -slb */
int restarted = 0;
#ifdef QUANTIFY
quantify_stop_recording_data ();
}
#ifdef RUN_TIME_REMAP
else
- /* obviously no-one uses this because where it was before initalized was
+ /* obviously no-one uses this because where it was before initialized was
*always* true */
run_time_remap (argv[0]);
#endif
It's a whole lot easier to do the conversion here than to
modify all the unexec routines to ensure that filename
conversion is applied everywhere. Don't worry about memory
- leakage because this call only happens once. */
- unexec (intoname_ext, symname_ext, (uintptr_t) my_edata, 0, 0);
+ leakage because this call only happens once. */
+ unexec (intoname_ext, symname_ext, (uintptr_t) my_edata, 0, 0);
#ifdef DOUG_LEA_MALLOC
- free (malloc_state_ptr);
+ free (malloc_state_ptr);
#endif
}
#endif /* not MSDOS and EMX */
#ifdef QUANTIFY
DEFUN ("quantify-start-recording-data", Fquantify_start_recording_data,
- 0, 0, 0, /*
+ 0, 0, "", /*
Start recording Quantify data.
*/
())
}
DEFUN ("quantify-stop-recording-data", Fquantify_stop_recording_data,
- 0, 0, 0, /*
+ 0, 0, "", /*
Stop recording Quantify data.
*/
())
return Qnil;
}
-DEFUN ("quantify-clear-data", Fquantify_clear_data, 0, 0, 0, /*
+DEFUN ("quantify-clear-data", Fquantify_clear_data, 0, 0, "", /*
Clear all Quantify data.
*/
())
complex_vars_of_emacs (void)
{
/* This is all related to path searching. */
-
+
DEFVAR_LISP ("emacs-program-name", &Vemacs_program_name /*
*Name of the Emacs variant.
For example, this may be \"xemacs\" or \"infodock\".
/* 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))
#include "faces.h"
#include "frame.h"
#include "glyphs.h"
-#include "hash.h"
#include "objects.h"
#include "specifier.h"
#include "window.h"
{
struct Lisp_Face *face = XFACE (obj);
- ((markobj) (face->name));
- ((markobj) (face->doc_string));
+ markobj (face->name);
+ markobj (face->doc_string);
- ((markobj) (face->foreground));
- ((markobj) (face->background));
- ((markobj) (face->font));
- ((markobj) (face->display_table));
- ((markobj) (face->background_pixmap));
- ((markobj) (face->underline));
- ((markobj) (face->strikethru));
- ((markobj) (face->highlight));
- ((markobj) (face->dim));
- ((markobj) (face->blinking));
- ((markobj) (face->reverse));
+ markobj (face->foreground);
+ markobj (face->background);
+ markobj (face->font);
+ markobj (face->display_table);
+ markobj (face->background_pixmap);
+ markobj (face->underline);
+ markobj (face->strikethru);
+ markobj (face->highlight);
+ markobj (face->dim);
+ markobj (face->blinking);
+ markobj (face->reverse);
- ((markobj) (face->charsets_warned_about));
+ markobj (face->charsets_warned_about);
return face->plist;
}
This isn't concerned with "unspecified" attributes, that's what
#'face-differs-from-default-p is for. */
static int
-face_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Face *f1 = XFACE (o1);
- struct Lisp_Face *f2 = XFACE (o2);
+ struct Lisp_Face *f1 = XFACE (obj1);
+ struct Lisp_Face *f2 = XFACE (obj2);
depth++;
};
static int
-add_face_to_list_mapper (CONST void *hash_key, void *hash_contents,
+add_face_to_list_mapper (Lisp_Object key, Lisp_Object value,
void *face_list_closure)
{
/* This function can GC */
- Lisp_Object key, contents;
- Lisp_Object *face_list;
struct face_list_closure *fcl =
(struct face_list_closure *) face_list_closure;
- CVOID_TO_LISP (key, hash_key);
- VOID_TO_LISP (contents, hash_contents);
- face_list = fcl->face_list;
- *face_list = Fcons (XFACE (contents)->name, *face_list);
+ *(fcl->face_list) = Fcons (XFACE (value)->name, (*fcl->face_list));
return 0;
}
\f
static int
-mark_face_as_clean_mapper (CONST void *hash_key, void *hash_contents,
+mark_face_as_clean_mapper (Lisp_Object key, Lisp_Object value,
void *flag_closure)
{
/* This function can GC */
- Lisp_Object key, contents;
int *flag = (int *) flag_closure;
- CVOID_TO_LISP (key, hash_key);
- VOID_TO_LISP (contents, hash_contents);
- XFACE (contents)->dirty = *flag;
+ XFACE (value)->dirty = *flag;
return 0;
}
for (i = 0; i < NUM_LEADING_BYTES; i++)
if (!NILP (cachel->font[i]) && !UNBOUNDP (cachel->font[i]))
- ((markobj) (cachel->font[i]));
+ markobj (cachel->font[i]);
}
- ((markobj) (cachel->face));
- ((markobj) (cachel->foreground));
- ((markobj) (cachel->background));
- ((markobj) (cachel->display_table));
- ((markobj) (cachel->background_pixmap));
+ markobj (cachel->face);
+ markobj (cachel->foreground);
+ markobj (cachel->background);
+ markobj (cachel->display_table);
+ markobj (cachel->background_pixmap);
}
}
if (WINDOWP (locale))
{
- struct frame *f = XFRAME (XWINDOW (locale)->frame);
- MARK_FRAME_FACES_CHANGED (f);
+ MARK_FRAME_FACES_CHANGED (XFRAME (XWINDOW (locale)->frame));
}
else if (FRAMEP (locale))
{
- struct frame *f = XFRAME (locale);
- MARK_FRAME_FACES_CHANGED (f);
+ MARK_FRAME_FACES_CHANGED (XFRAME (locale));
}
else if (DEVICEP (locale))
{
- struct device *d = XDEVICE (locale);
- MARK_DEVICE_FRAMES_FACES_CHANGED (d);
+ MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (locale));
}
else
{
Lisp_Object devcons, concons;
-
DEVICE_LOOP_NO_BREAK (devcons, concons)
MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (XCAR (devcons)));
}
void
complex_vars_of_faces (void)
{
- Vpermanent_faces_cache = make_lisp_hashtable (10, HASHTABLE_NONWEAK,
- HASHTABLE_EQ);
- Vtemporary_faces_cache = make_lisp_hashtable (0, HASHTABLE_WEAK,
- HASHTABLE_EQ);
+ Vpermanent_faces_cache =
+ make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
+ Vtemporary_faces_cache =
+ make_lisp_hash_table (0, HASH_TABLE_WEAK, HASH_TABLE_EQ);
/* Create the default face now so we know what it is immediately. */
list1 (Fcons (Qnil, Qnil)));
set_specifier_fallback (Fget (Vdefault_face, Qreverse, Qnil),
list1 (Fcons (Qnil, Qnil)));
-
+
/* gui-element is the parent face of all gui elements such as
modeline, vertical divider and toolbar. */
Vgui_element_face = Fmake_face (Qgui_element,
set_specifier_fallback (Fget (Vmodeline_face, Qbackground_pixmap, Qnil),
Fget (Vgui_element_face, Qbackground_pixmap,
Qunbound));
-
+
/* toolbar is another gui element */
Vtoolbar_face = Fmake_face (Qtoolbar,
build_string ("toolbar face"),
right sort are available on the system. In this case, the
whole program will just crash. For the moment, this is
OK (for debugging purposes) but we should fix this by
- storing a "blank font" if the instantation fails. */
+ storing a "blank font" if the instantiation fails. */
unsigned int dirty :1;
unsigned int updated :1;
/* #### Of course we should use a bit array or something. */
extern Lisp_Object Qstrikethru, Vbuilt_in_face_specifiers, Vdefault_face;
extern Lisp_Object Vleft_margin_face, Vpointer_face, Vright_margin_face;
-extern Lisp_Object Vtext_cursor_face, Vvertical_divider_face;
+extern Lisp_Object Vtext_cursor_face, Vvertical_divider_face;
extern Lisp_Object Vtoolbar_face, Vgui_element_face;
void mark_all_faces_as_clean (void);
#endif
Lisp_Object Qencode, Qdecode;
-Lisp_Object Vcoding_system_hashtable;
+Lisp_Object Vcoding_system_hash_table;
int enable_multibyte_characters;
{
struct Lisp_Coding_System *codesys = XCODING_SYSTEM (obj);
- (markobj) (CODING_SYSTEM_NAME (codesys));
- (markobj) (CODING_SYSTEM_DOC_STRING (codesys));
- (markobj) (CODING_SYSTEM_MNEMONIC (codesys));
- (markobj) (CODING_SYSTEM_EOL_LF (codesys));
- (markobj) (CODING_SYSTEM_EOL_CRLF (codesys));
- (markobj) (CODING_SYSTEM_EOL_CR (codesys));
+ markobj (CODING_SYSTEM_NAME (codesys));
+ markobj (CODING_SYSTEM_DOC_STRING (codesys));
+ markobj (CODING_SYSTEM_MNEMONIC (codesys));
+ markobj (CODING_SYSTEM_EOL_LF (codesys));
+ markobj (CODING_SYSTEM_EOL_CRLF (codesys));
+ markobj (CODING_SYSTEM_EOL_CR (codesys));
switch (CODING_SYSTEM_TYPE (codesys))
{
int i;
case CODESYS_ISO2022:
for (i = 0; i < 4; i++)
- (markobj) (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i));
+ markobj (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i));
if (codesys->iso2022.input_conv)
{
for (i = 0; i < Dynarr_length (codesys->iso2022.input_conv); i++)
{
struct charset_conversion_spec *ccs =
Dynarr_atp (codesys->iso2022.input_conv, i);
- (markobj) (ccs->from_charset);
- (markobj) (ccs->to_charset);
+ markobj (ccs->from_charset);
+ markobj (ccs->to_charset);
}
}
if (codesys->iso2022.output_conv)
{
struct charset_conversion_spec *ccs =
Dynarr_atp (codesys->iso2022.output_conv, i);
- (markobj) (ccs->from_charset);
- (markobj) (ccs->to_charset);
+ markobj (ccs->from_charset);
+ markobj (ccs->to_charset);
}
}
break;
case CODESYS_CCL:
- (markobj) (CODING_SYSTEM_CCL_DECODE (codesys));
- (markobj) (CODING_SYSTEM_CCL_ENCODE (codesys));
+ markobj (CODING_SYSTEM_CCL_DECODE (codesys));
+ markobj (CODING_SYSTEM_CCL_ENCODE (codesys));
break;
#endif /* MULE */
default:
break;
}
- (markobj) (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys));
+ markobj (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys));
return CODING_SYSTEM_POST_READ_CONVERSION (codesys);
}
{
switch (type)
{
+ default: abort ();
case EOL_LF: return Qlf;
case EOL_CRLF: return Qcrlf;
case EOL_CR: return Qcr;
case EOL_AUTODETECT: return Qnil;
- default: abort (); return Qnil; /* not reached */
}
}
else
CHECK_SYMBOL (coding_system_or_name);
- return Fgethash (coding_system_or_name, Vcoding_system_hashtable, Qnil);
+ return Fgethash (coding_system_or_name, Vcoding_system_hash_table, Qnil);
}
DEFUN ("get-coding-system", Fget_coding_system, 1, 1, 0, /*
};
static int
-add_coding_system_to_list_mapper (CONST void *hash_key, void *hash_contents,
+add_coding_system_to_list_mapper (Lisp_Object key, Lisp_Object value,
void *coding_system_list_closure)
{
/* This function can GC */
- Lisp_Object key, contents;
- Lisp_Object *coding_system_list;
struct coding_system_list_closure *cscl =
(struct coding_system_list_closure *) coding_system_list_closure;
- CVOID_TO_LISP (key, hash_key);
- VOID_TO_LISP (contents, hash_contents);
- coding_system_list = cscl->coding_system_list;
+ Lisp_Object *coding_system_list = cscl->coding_system_list;
- *coding_system_list = Fcons (XCODING_SYSTEM (contents)->name,
+ *coding_system_list = Fcons (XCODING_SYSTEM (value)->name,
*coding_system_list);
return 0;
}
GCPRO1 (coding_system_list);
coding_system_list_closure.coding_system_list = &coding_system_list;
- elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hashtable,
+ elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hash_table,
&coding_system_list_closure);
UNGCPRO;
{
Lisp_Object codesys_obj;
XSETCODING_SYSTEM (codesys_obj, codesys);
- Fputhash (name, codesys_obj, Vcoding_system_hashtable);
+ Fputhash (name, codesys_obj, Vcoding_system_hash_table);
return codesys_obj;
}
}
allocate_coding_system
(XCODING_SYSTEM_TYPE (old_coding_system),
new_name));
- Fputhash (new_name, new_coding_system, Vcoding_system_hashtable);
+ Fputhash (new_name, new_coding_system, Vcoding_system_hash_table);
}
{
{
switch (XCODING_SYSTEM_TYPE (Fget_coding_system (coding_system)))
{
+ default: abort ();
case CODESYS_AUTODETECT: return Qundecided;
#ifdef MULE
case CODESYS_SHIFT_JIS: return Qshift_jis;
#ifdef DEBUG_XEMACS
case CODESYS_INTERNAL: return Qinternal;
#endif
- default:
- abort ();
}
-
- return Qnil; /* not reached */
}
#ifdef MULE
and automatically marked. */
XSETLSTREAM (str_obj, str);
- (markobj) (str_obj);
+ markobj (str_obj);
if (str->imp->marker)
return (str->imp->marker) (str_obj, markobj);
else
and automatically marked. */
XSETLSTREAM (str_obj, str);
- (markobj) (str_obj);
+ markobj (str_obj);
if (str->imp->marker)
return (str->imp->marker) (str_obj, markobj);
else
Since the number of characters in Big5 is larger than maximum
characters in Emacs' charset (96x96), it can't be handled as one
- charset. So, in Emacs, Big5 is devided into two: `charset-big5-1'
+ charset. So, in Emacs, Big5 is divided into two: `charset-big5-1'
and `charset-big5-2'. Both <type>s are TYPE94x94. The former
contains frequently used characters and the latter contains less
frequently used characters. */
/* Determine coding system from coding format */
-#define FILE_NAME_CODING_SYSTEM \
- ((NILP (Vfile_name_coding_system) || \
- (EQ ((Vfile_name_coding_system), Qbinary))) ? \
- Qnil : Fget_coding_system (Vfile_name_coding_system))
-
/* #### not correct for all values of `fmt'! */
+static Lisp_Object
+external_data_format_to_coding_system (enum external_data_format fmt)
+{
+ switch (fmt)
+ {
+ case FORMAT_FILENAME:
+ case FORMAT_TERMINAL:
+ if (EQ (Vfile_name_coding_system, Qnil) ||
+ EQ (Vfile_name_coding_system, Qbinary))
+ return Qnil;
+ else
+ return Fget_coding_system (Vfile_name_coding_system);
#ifdef MULE
-#define FMT_CODING_SYSTEM(fmt) \
- (((fmt) == FORMAT_FILENAME) ? FILE_NAME_CODING_SYSTEM : \
- ((fmt) == FORMAT_CTEXT ) ? Fget_coding_system (Qctext) : \
- ((fmt) == FORMAT_TERMINAL) ? FILE_NAME_CODING_SYSTEM : \
- Qnil)
-#else
-#define FMT_CODING_SYSTEM(fmt) \
- (((fmt) == FORMAT_FILENAME) ? FILE_NAME_CODING_SYSTEM : \
- ((fmt) == FORMAT_TERMINAL) ? FILE_NAME_CODING_SYSTEM : \
- Qnil)
+ case FORMAT_CTEXT:
+ return Fget_coding_system (Qctext);
#endif
+ default:
+ return Qnil;
+ }
+}
Extbyte *
convert_to_external_format (CONST Bufbyte *ptr,
Extcount *len_out,
enum external_data_format fmt)
{
- Lisp_Object coding_system = FMT_CODING_SYSTEM (fmt);
+ Lisp_Object coding_system = external_data_format_to_coding_system (fmt);
if (!conversion_out_dynarr)
conversion_out_dynarr = Dynarr_new (Extbyte);
Bytecount *len_out,
enum external_data_format fmt)
{
- Lisp_Object coding_system = FMT_CODING_SYSTEM (fmt);
+ Lisp_Object coding_system = external_data_format_to_coding_system (fmt);
if (!conversion_in_dynarr)
conversion_in_dynarr = Dynarr_new (Bufbyte);
void
complex_vars_of_mule_coding (void)
{
- staticpro (&Vcoding_system_hashtable);
- Vcoding_system_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK,
- HASHTABLE_EQ);
+ staticpro (&Vcoding_system_hash_table);
+ Vcoding_system_hash_table =
+ make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
the_codesys_prop_dynarr = Dynarr_new (codesys_prop);
extern Lisp_Object Qno_iso6429, Qoutput_charset_conversion;
extern Lisp_Object Qpost_read_conversion, Qpre_write_conversion, Qseven;
extern Lisp_Object Qshift_jis, Qshort, Vcoding_system_for_read;
-extern Lisp_Object Vcoding_system_for_write, Vcoding_system_hashtable;
+extern Lisp_Object Vcoding_system_for_write, Vcoding_system_hash_table;
extern Lisp_Object Vfile_name_coding_system, Vkeyboard_coding_system;
extern Lisp_Object Vterminal_coding_system;
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. */
#include "buffer.h"
#include "bytecode.h"
-#include "commands.h"
#include "device.h"
#include "events.h"
#include "extents.h"
}
static int
-bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1);
- struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2);
+ struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
+ struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
!memcmp (v1->bits, v2->bits,
return XINT (Flength (seq));
else
{
- struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq);
+ struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
- return (b->flags.interactivep ? COMPILED_INTERACTIVE :
- b->flags.domainp ? COMPILED_DOMAIN :
+ return (f->flags.interactivep ? COMPILED_INTERACTIVE :
+ f->flags.domainp ? COMPILED_DOMAIN :
COMPILED_DOC_STRING)
+ 1;
}
return make_int (XSTRING_CHAR_LENGTH (sequence));
else if (CONSP (sequence))
{
- Lisp_Object tail;
- int i = 0;
-
- EXTERNAL_LIST_LOOP (tail, sequence)
- {
- QUIT;
- i++;
- }
-
- return make_int (i);
+ int len;
+ GET_EXTERNAL_LIST_LENGTH (sequence, len);
+ return make_int (len);
}
else if (VECTORP (sequence))
return make_int (XVECTOR_LENGTH (sequence));
}
}
-/* This does not check for quits. That is safe
- since it must terminate. */
-
DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
Return the length of a list, but avoid error or infinite loop.
This function never gets an error. If LIST is not really a list,
*/
(list))
{
- Lisp_Object halftail = list; /* Used to detect circular lists. */
- Lisp_Object tail;
- int len = 0;
+ Lisp_Object hare, tortoise;
+ int len;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (hare = tortoise = list, len = 0;
+ CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
+ hare = XCDR (hare), len++)
{
- if (EQ (tail, halftail) && len != 0)
- break;
- len++;
- if ((len & 1) == 0)
- halftail = XCDR (halftail);
+ if (len & 1)
+ tortoise = XCDR (tortoise);
}
return make_int (len);
return concat (nargs, args, c_bit_vector, 0);
}
-DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
-Return a copy of a list, vector, bit vector or string.
-The elements of a list or vector are not copied; they are shared
+/* Copy a (possibly dotted) list. LIST must be a cons.
+ Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
+static Lisp_Object
+copy_list (Lisp_Object list)
+{
+ Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
+ Lisp_Object last = list_copy;
+ Lisp_Object hare, tortoise;
+ int len;
+
+ for (tortoise = hare = XCDR (list), len = 1;
+ CONSP (hare);
+ hare = XCDR (hare), len++)
+ {
+ XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
+ last = XCDR (last);
+
+ if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
+ continue;
+ if (len & 1)
+ tortoise = XCDR (tortoise);
+ if (EQ (tortoise, hare))
+ signal_circular_list_error (list);
+ }
+
+ return list_copy;
+}
+
+DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
+Return a copy of list LIST, which may be a dotted list.
+The elements of LIST are not copied; they are shared
with the original.
*/
- (arg))
+ (list))
{
again:
- if (NILP (arg)) return arg;
- /* We handle conses separately because concat() is big and hairy and
- doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this
- than to fix concat() without worrying about breaking other things.
- */
- if (CONSP (arg))
- {
- Lisp_Object head = Fcons (XCAR (arg), XCDR (arg));
- Lisp_Object tail = head;
+ if (NILP (list)) return list;
+ if (CONSP (list)) return copy_list (list);
- for (arg = XCDR (arg); CONSP (arg); arg = XCDR (arg))
- {
- XCDR (tail) = Fcons (XCAR (arg), XCDR (arg));
- tail = XCDR (tail);
- QUIT;
- }
- return head;
- }
- if (STRINGP (arg)) return concat (1, &arg, c_string, 0);
- if (VECTORP (arg)) return concat (1, &arg, c_vector, 0);
- if (BIT_VECTORP (arg)) return concat (1, &arg, c_bit_vector, 0);
+ list = wrong_type_argument (Qlistp, list);
+ goto again;
+}
- check_losing_bytecode ("copy-sequence", arg);
- arg = wrong_type_argument (Qsequencep, arg);
+DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
+Return a copy of list, vector, bit vector or string SEQUENCE.
+The elements of a list or vector are not copied; they are shared
+with the original. SEQUENCE may be a dotted list.
+*/
+ (sequence))
+{
+ again:
+ if (NILP (sequence)) return sequence;
+ if (CONSP (sequence)) return copy_list (sequence);
+ if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
+ if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
+ if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
+
+ check_losing_bytecode ("copy-sequence", sequence);
+ sequence = wrong_type_argument (Qsequencep, sequence);
goto again;
}
Lisp_Object val;
CHECK_STRING (string);
- /* Historically, FROM could not be omitted. Whatever ... */
CHECK_INT (from);
get_string_range_char (string, from, to, &ccfr, &ccto,
GB_HISTORICAL_STRING_BEHAVIOR);
args_out_of_range (sequence, n);
#endif
}
- else if (STRINGP (sequence)
- || VECTORP (sequence)
- || BIT_VECTORP (sequence))
+ else if (STRINGP (sequence) ||
+ VECTORP (sequence) ||
+ BIT_VECTORP (sequence))
return Faref (sequence, n);
#ifdef LOSING_BYTECODE
else if (COMPILED_FUNCTIONP (sequence))
}
/* Utter perversity */
{
- struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence);
+ Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
switch (idx)
{
case COMPILED_ARGLIST:
- return b->arglist;
- case COMPILED_BYTECODE:
- return b->bytecodes;
+ return compiled_function_arglist (f);
+ case COMPILED_INSTRUCTIONS:
+ return compiled_function_instructions (f);
case COMPILED_CONSTANTS:
- return b->constants;
+ return compiled_function_constants (f);
case COMPILED_STACK_DEPTH:
- return make_int (b->maxdepth);
+ return compiled_function_stack_depth (f);
case COMPILED_DOC_STRING:
- return compiled_function_documentation (b);
+ return compiled_function_documentation (f);
case COMPILED_DOMAIN:
- return compiled_function_domain (b);
+ return compiled_function_domain (f);
case COMPILED_INTERACTIVE:
- if (b->flags.interactivep)
- return compiled_function_interactive (b);
+ if (f->flags.interactivep)
+ return compiled_function_interactive (f);
/* if we return nil, can't tell interactive with no args
from noninteractive. */
goto lose;
}
}
+DEFUN ("last", Flast, 1, 2, 0, /*
+Return the tail of list LIST, of length N (default 1).
+LIST may be a dotted list, but not a circular list.
+Optional argument N must be a non-negative integer.
+If N is zero, then the atom that terminates the list is returned.
+If N is greater than the length of LIST, then LIST itself is returned.
+*/
+ (list, n))
+{
+ int int_n, count;
+ Lisp_Object retval, tortoise, hare;
+
+ CHECK_LIST (list);
+
+ if (NILP (n))
+ int_n = 1;
+ else
+ {
+ CHECK_NATNUM (n);
+ int_n = XINT (n);
+ }
+
+ for (retval = tortoise = hare = list, count = 0;
+ CONSP (hare);
+ hare = XCDR (hare),
+ (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
+ count++)
+ {
+ if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ tortoise = XCDR (tortoise);
+ if (EQ (hare, tortoise))
+ signal_circular_list_error (list);
+ }
+
+ return retval;
+}
+
+DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
+Modify LIST to remove the last N (default 1) elements.
+If LIST has N or fewer elements, nil is returned and LIST is unmodified.
+*/
+ (list, n))
+{
+ int int_n;
+
+ CHECK_LIST (list);
+
+ if (NILP (n))
+ int_n = 1;
+ else
+ {
+ CHECK_NATNUM (n);
+ int_n = XINT (n);
+ }
+
+ {
+ Lisp_Object last_cons = list;
+
+ EXTERNAL_LIST_LOOP_1 (list)
+ {
+ if (int_n-- < 0)
+ last_cons = XCDR (last_cons);
+ }
+
+ if (int_n >= 0)
+ return Qnil;
+
+ XCDR (last_cons) = Qnil;
+ return list;
+ }
+}
+
+DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
+Return a copy of LIST with the last N (default 1) elements removed.
+If LIST has N or fewer elements, nil is returned.
+*/
+ (list, n))
+{
+ int int_n;
+
+ CHECK_LIST (list);
+
+ if (NILP (n))
+ int_n = 1;
+ else
+ {
+ CHECK_NATNUM (n);
+ int_n = XINT (n);
+ }
+
+ {
+ Lisp_Object retval = Qnil;
+ Lisp_Object tail = list;
+
+ EXTERNAL_LIST_LOOP_1 (list)
+ {
+ if (--int_n < 0)
+ {
+ retval = Fcons (XCAR (tail), retval);
+ tail = XCDR (tail);
+ }
+ }
+
+ return Fnreverse (retval);
+ }
+}
+
DEFUN ("member", Fmember, 2, 2, 0, /*
Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
The value is actually the tail of LIST whose car is ELT.
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- CONCHECK_CONS (tail);
- if (internal_equal (elt, XCAR (tail), 0))
+ if (internal_equal (elt, list_elt, 0))
return tail;
- QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- CONCHECK_CONS (tail);
- if (internal_old_equal (elt, XCAR (tail), 0))
+ if (internal_old_equal (elt, list_elt, 0))
return tail;
- QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- REGISTER Lisp_Object tem;
- CONCHECK_CONS (tail);
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
return tail;
- QUIT;
}
return Qnil;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object list_elt, tail;
+ EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
{
- REGISTER Lisp_Object tem;
- CONCHECK_CONS (tail);
- if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
+ if (HACKEQ_UNSAFE (elt, list_elt))
return tail;
- QUIT;
}
return Qnil;
}
Lisp_Object
memq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- REGISTER Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object list_elt, tail;
+ LIST_LOOP_3 (list_elt, list, tail)
{
- REGISTER Lisp_Object tem;
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
return tail;
}
return Qnil;
(key, list))
{
/* This function can GC. */
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_equal (XCAR (elt), key, 0))
+ if (internal_equal (key, elt_car, 0))
return elt;
- QUIT;
}
return Qnil;
}
(key, list))
{
/* This function can GC. */
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0))
+ if (internal_old_equal (key, elt_car, 0))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem)))
+ if (HACKEQ_UNSAFE (key, elt_car))
return elt;
- QUIT;
}
return Qnil;
}
assq_no_quit (Lisp_Object key, Lisp_Object list)
{
/* This cannot GC. */
- REGISTER Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object elt;
+ LIST_LOOP_2 (elt, list)
{
- REGISTER Lisp_Object tem, elt;
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
- return elt;
+ Lisp_Object elt_car = XCAR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
+ return elt;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_equal (XCDR (elt), key, 0))
+ if (internal_equal (key, elt_cdr, 0))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0))
+ if (internal_old_equal (key, elt_cdr, 0))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
return elt;
- QUIT;
}
return Qnil;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail;
- LIST_LOOP (tail, list)
+ Lisp_Object elt, elt_car, elt_cdr;
+ EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
{
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem)))
+ if (HACKEQ_UNSAFE (key, elt_cdr))
return elt;
- QUIT;
}
return Qnil;
}
+/* Like Frassq, but caller must ensure that LIST is properly
+ nil-terminated and ebola-free. */
Lisp_Object
rassq_no_quit (Lisp_Object key, Lisp_Object list)
{
- REGISTER Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object elt;
+ LIST_LOOP_2 (elt, list)
{
- REGISTER Lisp_Object elt, tem;
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
+ Lisp_Object elt_cdr = XCDR (elt);
+ if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
return elt;
}
return Qnil;
*/
(elt, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- CONCHECK_CONS (tail);
- if (internal_equal (elt, XCAR (tail), 0))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_equal (elt, list_elt, 0)));
return list;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- CONCHECK_CONS (tail);
- if (internal_old_equal (elt, XCAR (tail), 0))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (internal_old_equal (elt, list_elt, 0)));
return list;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object tem;
- CONCHECK_CONS (tail);
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
return list;
}
*/
(elt, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object tem;
- CONCHECK_CONS (tail);
- if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object list_elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
+ (HACKEQ_UNSAFE (elt, list_elt)));
return list;
}
-/* no quit, no errors; be careful */
+/* Like Fdelq, but caller must ensure that LIST is properly
+ nil-terminated and ebola-free. */
Lisp_Object
delq_no_quit (Lisp_Object elt, Lisp_Object list)
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (CONSP (tail))
- {
- REGISTER Lisp_Object tem;
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- }
+ Lisp_Object list_elt;
+ LIST_LOOP_DELETE_IF (list_elt, list,
+ (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
return list;
}
{
REGISTER Lisp_Object tail = list;
REGISTER Lisp_Object prev = Qnil;
- struct Lisp_Cons *cons_to_free = NULL;
- while (CONSP (tail))
+ while (!NILP (tail))
{
- REGISTER Lisp_Object tem;
- if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem))
+ REGISTER Lisp_Object tem = XCAR (tail);
+ if (EQ (elt, tem))
{
+ Lisp_Object cons_to_free = tail;
if (NILP (prev))
list = XCDR (tail);
else
XCDR (prev) = XCDR (tail);
- cons_to_free = XCONS (tail);
+ tail = XCDR (tail);
+ free_cons (XCONS (cons_to_free));
}
else
- prev = tail;
- tail = XCDR (tail);
- if (cons_to_free)
{
- free_cons (cons_to_free);
- cons_to_free = NULL;
+ prev = tail;
+ tail = XCDR (tail);
}
}
return list;
*/
(key, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_equal (key, XCAR (elt), 0))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ internal_equal (key, XCAR (elt), 0)));
return list;
}
*/
(key, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
return list;
}
Lisp_Object
remassq_no_quit (Lisp_Object key, Lisp_Object list)
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (CONSP (tail))
- {
- REGISTER Lisp_Object elt, tem;
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem)))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- }
+ Lisp_Object elt;
+ LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
return list;
}
*/
(value, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object elt;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && internal_equal (value, XCDR (elt), 0))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ internal_equal (value, XCDR (elt), 0)));
return list;
}
*/
(value, list))
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (!NILP (tail))
- {
- REGISTER Lisp_Object elt, tem;
- CONCHECK_CONS (tail);
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- QUIT;
- }
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
return list;
}
-/* no quit, no errors; be careful */
-
+/* Like Fremrassq, fast and unsafe; be careful */
Lisp_Object
remrassq_no_quit (Lisp_Object value, Lisp_Object list)
{
- REGISTER Lisp_Object tail = list;
- REGISTER Lisp_Object prev = Qnil;
-
- while (CONSP (tail))
- {
- REGISTER Lisp_Object elt, tem;
- elt = XCAR (tail);
- if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem)))
- {
- if (NILP (prev))
- list = XCDR (tail);
- else
- XCDR (prev) = XCDR (tail);
- }
- else
- prev = tail;
- tail = XCDR (tail);
- }
+ Lisp_Object elt;
+ LIST_LOOP_DELETE_IF (elt, list,
+ (CONSP (elt) &&
+ EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
return list;
}
while (!NILP (tail))
{
REGISTER Lisp_Object next;
- QUIT;
CONCHECK_CONS (tail);
next = XCDR (tail);
XCDR (tail) = prev;
*/
(list))
{
- REGISTER Lisp_Object tail;
- Lisp_Object new = Qnil;
-
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ Lisp_Object reversed_list = Qnil;
+ Lisp_Object elt;
+ EXTERNAL_LIST_LOOP_2 (elt, list)
{
- new = Fcons (XCAR (tail), new);
- QUIT;
+ reversed_list = Fcons (elt, reversed_list);
}
- if (!NILP (tail))
- dead_wrong_type_argument (Qlistp, tail);
- return new;
+ return reversed_list;
}
\f
static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
Lisp_Object
internal_plist_get (Lisp_Object plist, Lisp_Object property)
{
- Lisp_Object tail = plist;
+ Lisp_Object tail;
- for (; !NILP (tail); tail = XCDR (XCDR (tail)))
+ for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
{
- struct Lisp_Cons *c = XCONS (tail);
- if (EQ (c->car, property))
- return XCAR (c->cdr);
+ if (EQ (XCAR (tail), property))
+ return XCAR (XCDR (tail));
}
return Qunbound;
int
internal_remprop (Lisp_Object *plist, Lisp_Object property)
{
- Lisp_Object tail = *plist;
-
- if (NILP (tail))
- return 0;
-
- if (EQ (XCAR (tail), property))
- {
- *plist = XCDR (XCDR (tail));
- return 1;
- }
+ Lisp_Object tail, prev;
- for (tail = XCDR (tail); !NILP (XCDR (tail));
+ for (tail = *plist, prev = Qnil;
+ !NILP (tail);
tail = XCDR (XCDR (tail)))
{
- struct Lisp_Cons *c = XCONS (tail);
- if (EQ (XCAR (c->cdr), property))
+ if (EQ (XCAR (tail), property))
{
- c->cdr = XCDR (XCDR (c->cdr));
+ if (NILP (prev))
+ *plist = XCDR (XCDR (tail));
+ else
+ XCDR (XCDR (prev)) = XCDR (XCDR (tail));
return 1;
}
+ else
+ prev = tail;
}
return 0;
Lisp_Object *tortsave = *tortoise;
/* Note that our "fixing" may be more brutal than necessary,
- but it's the user's own problem, not ours. if they went in and
+ but it's the user's own problem, not ours, if they went in and
manually fucked up a plist. */
for (i = 0; i < 2; i++)
(plist, prop, default_))
{
Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
- if (UNBOUNDP (val))
- return default_;
- return val;
+ return UNBOUNDP (val) ? default_ : val;
}
DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
*/
(plist, prop))
{
- return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? Qnil : Qt;
+ Lisp_Object val = Fplist_get (plist, prop, Qunbound);
+ return UNBOUNDP (val) ? Qnil : Qt;
}
DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
/* external_remprop returns 1 if it removed any property.
We have to loop till it didn't remove anything, in case
the property occurs many times. */
- while (external_remprop (&XCDR (next), prop, 0, ERROR_ME));
+ while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
+ DO_NOTHING;
plist = Fcdr (next);
}
Extract a value from a lax property list.
LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparions between properties is done
+VALUE1 PROP2 VALUE2...), where comparisons between properties is done
using `equal' instead of `eq'. This function returns the value
corresponding to the given PROP, or DEFAULT if PROP is not one of the
properties on the list.
DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
Change value in LAX-PLIST of PROP to VAL.
LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparions between properties is done
+VALUE1 PROP2 VALUE2...), where comparisons between properties is done
using `equal' instead of `eq'. PROP is usually a symbol and VAL is
any object. If PROP is already a property on the list, its value is
set to VAL, otherwise the new PROP VAL pair is added. The new plist
DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
Remove from LAX-PLIST the property PROP and its value.
LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparions between properties is done
+VALUE1 PROP2 VALUE2...), where comparisons between properties is done
using `equal' instead of `eq'. PROP is usually a symbol. The new
plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
sure to use the new value. The LAX-PLIST is modified by side effects.
DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
Return t if PROP has a value specified in LAX-PLIST.
LAX-PLIST is a lax property list, which is a list of the form \(PROP1
-VALUE1 PROP2 VALUE2...), where comparions between properties is done
+VALUE1 PROP2 VALUE2...), where comparisons between properties is done
using `equal' instead of `eq'.
*/
(lax_plist, prop))
/* external_remprop returns 1 if it removed any property.
We have to loop till it didn't remove anything, in case
the property occurs many times. */
- while (external_remprop (&XCDR (next), prop, 1, ERROR_ME));
+ while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
+ DO_NOTHING;
lax_plist = Fcdr (next);
}
*/
(object, propname, default_))
{
- Lisp_Object val;
-
/* Various places in emacs call Fget() and expect it not to quit,
so don't quit. */
/* It's easiest to treat symbols specially because they may not
be an lrecord */
if (SYMBOLP (object))
- val = symbol_getprop (object, propname, default_);
+ return symbol_getprop (object, propname, default_);
else if (STRINGP (object))
- val = string_getprop (XSTRING (object), propname, default_);
+ return string_getprop (XSTRING (object), propname, default_);
else if (LRECORDP (object))
{
- CONST struct lrecord_implementation
- *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
- if (imp->getprop)
- {
- val = (imp->getprop) (object, propname);
- if (UNBOUNDP (val))
- val = default_;
- }
- else
+ CONST struct lrecord_implementation *imp
+ = XRECORD_LHEADER_IMPLEMENTATION (object);
+ if (!imp->getprop)
goto noprops;
+
+ {
+ Lisp_Object val = (imp->getprop) (object, propname);
+ if (UNBOUNDP (val))
+ val = default_;
+ return val;
+ }
}
else
{
noprops:
signal_simple_error ("Object type has no properties", object);
+ return Qnil; /* Not reached */
}
-
- return val;
}
DEFUN ("put", Fput, 3, 3, 0, /*
\f
int
-internal_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
do_cdr:
#endif
QUIT;
- if (EQ_WITH_EBOLA_NOTICE (o1, o2))
+ if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
return 1;
/* Note that (equal 20 20.0) should be nil */
- else if (XTYPE (o1) != XTYPE (o2))
+ if (XTYPE (obj1) != XTYPE (obj2))
return 0;
#ifndef LRECORD_CONS
- else if (CONSP (o1))
+ if (CONSP (obj1))
{
- if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1))
+ if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1))
return 0;
- o1 = XCDR (o1);
- o2 = XCDR (o2);
+ obj1 = XCDR (obj1);
+ obj2 = XCDR (obj2);
goto do_cdr;
}
#endif
#ifndef LRECORD_VECTOR
- else if (VECTORP (o1))
+ if (VECTORP (obj1))
{
- Lisp_Object *v1 = XVECTOR_DATA (o1);
- Lisp_Object *v2 = XVECTOR_DATA (o2);
- int len = XVECTOR_LENGTH (o1);
- if (len != XVECTOR_LENGTH (o2))
+ Lisp_Object *v1 = XVECTOR_DATA (obj1);
+ Lisp_Object *v2 = XVECTOR_DATA (obj2);
+ int len = XVECTOR_LENGTH (obj1);
+ if (len != XVECTOR_LENGTH (obj2))
return 0;
while (len--)
if (!internal_equal (*v1++, *v2++, depth + 1))
}
#endif
#ifndef LRECORD_STRING
- else if (STRINGP (o1))
+ if (STRINGP (obj1))
{
Bytecount len;
- return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) &&
- !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len));
+ return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
+ !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
}
#endif
- else if (LRECORDP (o1))
+ if (LRECORDP (obj1))
{
CONST struct lrecord_implementation
- *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
- *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
- if (imp1 != imp2)
- return 0;
- else if (imp1->equal == 0)
+ *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
+ *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
+
+ return (imp1 == imp2) &&
/* EQ-ness of the objects was noticed above */
- return 0;
- else
- return (imp1->equal) (o1, o2, depth);
+ (imp1->equal && (imp1->equal) (obj1, obj2, depth));
}
return 0;
but that seems unlikely. */
static int
-internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
do_cdr:
#endif
QUIT;
- if (HACKEQ_UNSAFE (o1, o2))
+ if (HACKEQ_UNSAFE (obj1, obj2))
return 1;
/* Note that (equal 20 20.0) should be nil */
- else if (XTYPE (o1) != XTYPE (o2))
+ if (XTYPE (obj1) != XTYPE (obj2))
return 0;
#ifndef LRECORD_CONS
- else if (CONSP (o1))
+ if (CONSP (obj1))
{
- if (!internal_old_equal (XCAR (o1), XCAR (o2), depth + 1))
+ if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1))
return 0;
- o1 = XCDR (o1);
- o2 = XCDR (o2);
+ obj1 = XCDR (obj1);
+ obj2 = XCDR (obj2);
goto do_cdr;
}
#endif
#ifndef LRECORD_VECTOR
- else if (VECTORP (o1))
+ if (VECTORP (obj1))
{
- int indice;
- int len = XVECTOR_LENGTH (o1);
- if (len != XVECTOR_LENGTH (o2))
- return 0;
- for (indice = 0; indice < len; indice++)
- {
- if (!internal_old_equal (XVECTOR_DATA (o1) [indice],
- XVECTOR_DATA (o2) [indice],
- depth + 1))
- return 0;
- }
- return 1;
- }
-#endif
-#ifndef LRECORD_STRING
- else if (STRINGP (o1))
- {
- Bytecount len = XSTRING_LENGTH (o1);
- if (len != XSTRING_LENGTH (o2))
- return 0;
- if (memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len))
+ Lisp_Object *v1 = XVECTOR_DATA (obj1);
+ Lisp_Object *v2 = XVECTOR_DATA (obj2);
+ int len = XVECTOR_LENGTH (obj1);
+ if (len != XVECTOR_LENGTH (obj2))
return 0;
+ while (len--)
+ if (!internal_old_equal (*v1++, *v2++, depth + 1))
+ return 0;
return 1;
}
#endif
- else if (LRECORDP (o1))
- {
- CONST struct lrecord_implementation
- *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1),
- *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2);
- if (imp1 != imp2)
- return 0;
- else if (imp1->equal == 0)
- /* EQ-ness of the objects was noticed above */
- return 0;
- else
- return (imp1->equal) (o1, o2, depth);
- }
- return 0;
+ return internal_equal (obj1, obj2, depth);
}
DEFUN ("equal", Fequal, 2, 2, 0, /*
Vectors and strings are compared element by element.
Numbers are compared by value. Symbols must match exactly.
*/
- (o1, o2))
+ (obj1, obj2))
{
- return internal_equal (o1, o2, 0) ? Qt : Qnil;
+ return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
}
DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
This function is provided only for byte-code compatibility with v19.
Do not use it.
*/
- (o1, o2))
+ (obj1, obj2))
{
- return internal_old_equal (o1, o2, 0) ? Qt : Qnil;
+ return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
}
\f
}
Lisp_Object
-nconc2 (Lisp_Object s1, Lisp_Object s2)
+nconc2 (Lisp_Object arg1, Lisp_Object arg2)
{
Lisp_Object args[2];
- args[0] = s1;
- args[1] = s2;
- return Fnconc (2, args);
+ struct gcpro gcpro1;
+ args[0] = arg1;
+ args[1] = arg2;
+
+ GCPRO1 (args[0]);
+ gcpro1.nvars = 2;
+
+ RETURN_UNGCPRO (bytecode_nconc2 (args));
+}
+
+Lisp_Object
+bytecode_nconc2 (Lisp_Object *args)
+{
+ retry:
+
+ if (CONSP (args[0]))
+ {
+ /* (setcdr (last args[0]) args[1]) */
+ Lisp_Object tortoise, hare;
+ int count;
+
+ for (hare = tortoise = args[0], count = 0;
+ CONSP (XCDR (hare));
+ hare = XCDR (hare), count++)
+ {
+ if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ tortoise = XCDR (tortoise);
+ if (EQ (hare, tortoise))
+ signal_circular_list_error (args[0]);
+ }
+ XCDR (hare) = args[1];
+ return args[0];
+ }
+ else if (NILP (args[0]))
+ {
+ return args[1];
+ }
+ else
+ {
+ args[0] = wrong_type_argument (args[0], Qlistp);
+ goto retry;
+ }
}
DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
Lisp_Object val = args[argnum];
if (CONSP (val))
{
- /* Found the first cons, which will be our return value. */
- Lisp_Object last = val;
+ /* `val' is the first cons, which will be our return value. */
+ /* `last_cons' will be the cons cell to mutate. */
+ Lisp_Object last_cons = val;
+ Lisp_Object tortoise = val;
for (argnum++; argnum < nargs; argnum++)
{
Lisp_Object next = args[argnum];
- redo:
+ retry:
if (CONSP (next) || argnum == nargs -1)
{
/* (setcdr (last val) next) */
- while (CONSP (XCDR (last)))
+ int count;
+
+ for (count = 0;
+ CONSP (XCDR (last_cons));
+ last_cons = XCDR (last_cons), count++)
{
- last = XCDR (last);
- QUIT;
+ if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
+
+ if (count & 1)
+ tortoise = XCDR (tortoise);
+ if (EQ (last_cons, tortoise))
+ signal_circular_list_error (args[argnum-1]);
}
- XCDR (last) = next;
+ XCDR (last_cons) = next;
}
else if (NILP (next))
{
else
{
next = wrong_type_argument (next, Qlistp);
- goto redo;
+ goto retry;
}
}
RETURN_UNGCPRO (val);
ways these functions can blow up, and we don't want to have memory
leaks in those cases. */
#define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
- if ((len) > MAX_ALLOCA) \
+ size_t XOA_len = (len); \
+ if (XOA_len > MAX_ALLOCA) \
{ \
- ptr = (type *)xmalloc ((len) * sizeof (type)); \
- speccount = specpdl_depth (); \
+ ptr = xnew_array (type, XOA_len); \
record_unwind_protect (free_malloced_ptr, \
make_opaque_ptr ((void *)ptr)); \
} \
else \
- ptr = alloca_array (type, len); \
+ ptr = alloca_array (type, XOA_len); \
} while (0)
-#define XMALLOC_UNBIND(ptr, len) do { \
- if ((len) > MAX_ALLOCA) \
- unbind_to (speccount, Qnil); \
+#define XMALLOC_UNBIND(ptr, len, speccount) do { \
+ if ((len) > MAX_ALLOCA) \
+ unbind_to (speccount, Qnil); \
} while (0)
DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
struct buffer *buf = current_buffer;
Bufpos begv, zv, old_pt = BUF_PT (buf);
Lisp_Object input;
- int speccount;
+ int speccount = specpdl_depth();
get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
+ barf_if_buffer_read_only (buf, begv, zv);
/* We need to allocate enough room for encoding the text.
We need 33 1/3% more space, plus a newline every 76
/* Now we have encoded the region, so we insert the new contents
and delete the old. (Insert first in order to preserve markers.) */
buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
- XMALLOC_UNBIND (encoded, allength);
+ XMALLOC_UNBIND (encoded, allength, speccount);
buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
/* Simulate FSF Emacs: if point was in the region, place it at the
Bytind encoded_length;
Bufbyte *encoded;
Lisp_Object input, result;
- int speccount;
+ int speccount = specpdl_depth();
CHECK_STRING (string);
abort ();
Lstream_delete (XLSTREAM (input));
result = make_string (encoded, encoded_length);
- XMALLOC_UNBIND (encoded, allength);
+ XMALLOC_UNBIND (encoded, allength, speccount);
return result;
}
Bytind decoded_length;
Charcount length, cc_decoded_length;
Lisp_Object input;
- int speccount;
+ int speccount = specpdl_depth();
get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
+ barf_if_buffer_read_only (buf, begv, zv);
+
length = zv - begv;
input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
if (decoded_length < 0)
{
/* The decoding wasn't possible. */
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
+ XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
return Qnil;
}
and delete the old. (Insert first in order to preserve markers.) */
BUF_SET_PT (buf, begv);
buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
+ XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
buffer_delete_range (buf, begv + cc_decoded_length,
zv + cc_decoded_length, 0);
Bytind decoded_length;
Charcount length, cc_decoded_length;
Lisp_Object input, result;
- int speccount;
+ int speccount = specpdl_depth();
CHECK_STRING (string);
if (decoded_length < 0)
{
+ /* The decoding wasn't possible. */
+ XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
return Qnil;
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
}
result = make_string (decoded, decoded_length);
- XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN);
+ XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
return result;
}
\f
DEFSUBR (Fconcat);
DEFSUBR (Fvconcat);
DEFSUBR (Fbvconcat);
+ DEFSUBR (Fcopy_list);
DEFSUBR (Fcopy_sequence);
DEFSUBR (Fcopy_alist);
DEFSUBR (Fcopy_tree);
DEFSUBR (Fnthcdr);
DEFSUBR (Fnth);
DEFSUBR (Felt);
+ DEFSUBR (Flast);
+ DEFSUBR (Fbutlast);
+ DEFSUBR (Fnbutlast);
DEFSUBR (Fmember);
DEFSUBR (Fold_member);
DEFSUBR (Fmemq);
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
#include "scrollbar.h"
#include "window.h"
-#include <errno.h>
-#include "sysdep.h"
-
Lisp_Object Vselect_frame_hook, Qselect_frame_hook;
Lisp_Object Vdeselect_frame_hook, Qdeselect_frame_hook;
Lisp_Object Vcreate_frame_hook, Qcreate_frame_hook;
{
struct frame *f = XFRAME (obj);
-#define MARKED_SLOT(x) ((markobj) (f->x));
+#define MARKED_SLOT(x) ((void) (markobj (f->x)));
#include "frameslots.h"
if (FRAME_LIVE_P (f)) /* device is nil for a dead frame */
XWINDOW (root_window)->frame = frame;
/* 10 is arbitrary,
- just so that there is "something there."
+ Just so that there is "something there."
Correct size will be set up later with change_frame_size. */
- f->width = 10;
+ f->width = 10;
f->height = 10;
XWINDOW (root_window)->pixel_width = 10;
void
invalidate_vertical_divider_cache_in_frame (struct frame *f)
{
- /* Invalidate cached value of needs_vertical_divider_p in
+ /* Invalidate cached value of needs_vertical_divider_p in
every and all windows */
map_windows (f, invalidate_vertical_divider_cache_in_window, 0);
}
#ifdef HAVE_TOOLBARS
if (!EQ (f->last_nonminibuf_window, window))
MARK_TOOLBAR_CHANGED;
-#endif
+#endif
f->last_nonminibuf_window = window;
}
}
/* when frame_conversion_internal() calculated the number of rows/cols
in the frame, the theoretical toolbar sizes were subtracted out.
- The caluclations below adjust for real toolbar height/width in
+ The calculations below adjust for real toolbar height/width in
frame, which may be different from frame spec, taking the above
fact into account */
new_pixheight +=
+ 2 * FRAME_THEORETICAL_TOP_TOOLBAR_BORDER_WIDTH (f)
- FRAME_REAL_TOP_TOOLBAR_HEIGHT (f)
- 2 * FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f);
-
+
new_pixheight +=
+ FRAME_THEORETICAL_BOTTOM_TOOLBAR_HEIGHT (f)
+ 2 * FRAME_THEORETICAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f)
+ 2 * FRAME_THEORETICAL_LEFT_TOOLBAR_BORDER_WIDTH (f)
- FRAME_REAL_LEFT_TOOLBAR_WIDTH (f)
- 2 * FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH (f);
-
+
new_pixwidth +=
+ FRAME_THEORETICAL_RIGHT_TOOLBAR_WIDTH (f)
+ 2 * FRAME_THEORETICAL_RIGHT_TOOLBAR_BORDER_WIDTH (f)
- FRAME_REAL_RIGHT_TOOLBAR_WIDTH (f)
- 2 * FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH (f);
-
+
/* Adjust the width for the end glyph which may be a different width
than the default character width. */
{
FRAME_CHARWIDTH (f) = FRAME_WIDTH (f);
FRAME_CHARHEIGHT (f) = FRAME_HEIGHT (f);
}
-
+
MARK_FRAME_TOOLBARS_CHANGED (f);
MARK_FRAME_CHANGED (f);
f->echo_area_garbaged = 1;
#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;
#include "buffer.h"
#include "frame.h"
-#include "insdel.h"
#include "opaque.h"
-#include "imgproc.h"
#include "sysfile.h"
#ifdef HAVE_PNG
#include "file-coding.h"
#endif
-#if INTBITS == 32
-# define FOUR_BYTE_TYPE unsigned int
-#elif LONGBITS == 32
-# define FOUR_BYTE_TYPE unsigned long
-#elif SHORTBITS == 32
-# define FOUR_BYTE_TYPE unsigned short
-#else
-#error What kind of strange-ass system are we running on?
-#endif
-
#ifdef HAVE_TIFF
DEFINE_IMAGE_INSTANTIATOR_FORMAT (tiff);
Lisp_Object Qtiff;
{
/* we're relying on the jpeg driver to do any other conversions,
or signal an error if the conversion isn't supported. */
- cinfo.out_color_space = JCS_RGB;
+ cinfo.out_color_space = JCS_RGB;
}
/* Step 5: Start decompressor */
for (i = 0; i < cinfo.output_width; i++)
{
int clr;
- if (jpeg_gray)
+ if (jpeg_gray)
{
unsigned char val;
#if (BITS_IN_JSAMPLE == 8)
/* Step 6.5: Create the pixmap and set up the image instance */
/* now instantiate */
- MAYBE_DEVMETH (XDEVICE (ii->device),
+ MAYBE_DEVMETH (XDEVICE (ii->device),
init_image_instance_from_eimage,
- (ii, cinfo.output_width, cinfo.output_height,
- unwind.eimage, dest_mask,
+ (ii, cinfo.output_width, cinfo.output_height,
+ unwind.eimage, dest_mask,
instantiator, domain));
/* Step 7: Finish decompression */
gif_read_from_memory(GifByteType *buf, size_t size, VoidPtr data)
{
gif_memory_storage *mem = (gif_memory_storage*)data;
-
+
if (size > (mem->len - mem->index))
- return -1;
+ return (size_t) -1;
memcpy(buf, mem->bytes + mem->index, size);
mem->index = mem->index + size;
return size;
Extcount len;
int height = 0;
int width = 0;
-
+
xzero (unwind);
record_unwind_protect (gif_instantiate_unwind, make_opaque_ptr (&unwind));
-
+
/* 1. Now decode the data. */
-
+
{
Lisp_Object data = find_keyword_in_vector (instantiator, Q_data);
-
+
assert (!NILP (data));
-
+
if (!(unwind.giffile = GifSetup()))
signal_image_error ("Insufficent memory to instantiate GIF image", instantiator);
-
+
/* set up error facilities */
if (setjmp(gif_err.setjmp_buffer))
{
signal_image_error_2 ("GIF decoding error", errstring, instantiator);
}
GifSetErrorFunc(unwind.giffile, (Gif_error_func)gif_error_func, (VoidPtr)&gif_err);
-
+
GET_STRING_BINARY_DATA_ALLOCA (data, bytes, len);
mem_struct.bytes = bytes;
mem_struct.len = len;
GifSetReadFunc(unwind.giffile, gif_read_from_memory, (VoidPtr)&mem_struct);
GifSetCloseFunc(unwind.giffile, gif_memory_close, (VoidPtr)&mem_struct);
DGifInitRead(unwind.giffile);
-
+
/* Then slurp the image into memory, decoding along the way.
The result is the image in a simple one-byte-per-pixel
format (#### the GIF routines only support 8-bit GIFs,
it appears). */
DGifSlurp (unwind.giffile);
}
-
+
/* 3. Now create the EImage */
{
ColorMapObject *cmo = unwind.giffile->SColorMap;
0, 8, 16, ..., 4, 12, 20, ..., 2, 6, 10, ..., 1, 3, 5, ... */
static int InterlacedOffset[] = { 0, 4, 2, 1 };
static int InterlacedJumps[] = { 8, 8, 4, 2 };
-
+
height = unwind.giffile->SHeight;
width = unwind.giffile->SWidth;
unwind.eimage = (unsigned char*) xmalloc (width * height * 3);
if (!unwind.eimage)
signal_image_error("Unable to allocate enough memory for image", instantiator);
-
+
/* write the data in EImage format (8bit RGB triples) */
-
+
/* Note: We just use the first image in the file and ignore the rest.
We check here that that image covers the full "screen" size.
I don't know whether that's always the case.
|| unwind.giffile->SavedImages[0].ImageDesc.Top != 0)
signal_image_error ("First image in GIF file is not full size",
instantiator);
-
+
interlace = unwind.giffile->SavedImages[0].ImageDesc.Interlace;
pass = 0;
row = interlace ? InterlacedOffset[pass] : 0;
if (interlace)
if (row >= height) {
row = InterlacedOffset[++pass];
- while (row > height)
+ while (row > height)
row = InterlacedOffset[++pass];
}
eip = unwind.eimage + (row * width * 3);
}
}
/* now instantiate */
- MAYBE_DEVMETH (XDEVICE (ii->device),
+ MAYBE_DEVMETH (XDEVICE (ii->device),
init_image_instance_from_eimage,
- (ii, width, height, unwind.eimage, dest_mask,
+ (ii, width, height, unwind.eimage, dest_mask,
instantiator, domain));
-
+
unbind_to (speccount, Qnil);
}
/* jh 98/03/12 - #### AARRRGH! libpng includes jmp_buf inside its own
structure, and there are cases where the size can be different from
- between inside the libarary, and inside the code! To do an end run
+ between inside the library, and inside the code! To do an end run
around this, use our own error functions, and don't rely on things
passed in the png_ptr to them. This is an ugly hack and must
go away when the lisp engine is threaded! */
png_destroy_read_struct (&png_ptr, (png_infopp)NULL, (png_infopp)NULL);
signal_image_error ("Error obtaining memory for png_read", instantiator);
}
-
+
xzero (unwind);
unwind.png_ptr = png_ptr;
unwind.info_ptr = info_ptr;
and is no longer usable for previous versions. jh
*/
- /* Set the jmp_buf reurn context for png_error ... if this returns !0, then
+ /* Set the jmp_buf return context for png_error ... if this returns !0, then
we ran into a problem somewhere, and need to clean up after ourselves. */
if (setjmp (png_err_stct.setjmp_buffer))
{
/* libpng expects that the image buffer passed in contains a
picture to draw on top of if the png has any transparencies.
This could be a good place to pass that in... */
-
+
row_pointers = xnew_array (png_byte *, height);
for (y = 0; y < height; y++)
my_background.green = XINT (XCAR (XCDR (rgblist)));
my_background.blue = XINT (XCAR (XCDR (XCDR (rgblist))));
}
-
+
if (png_get_bKGD (png_ptr, info_ptr, &image_background))
png_set_background (png_ptr, image_background,
PNG_BACKGROUND_GAMMA_FILE, 1, 1.0);
- else
+ else
png_set_background (png_ptr, &my_background,
PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0);
}
/* Now that we're using EImage, ask for 8bit RGB triples for any type
of image*/
- /* convert palatte images to full RGB */
+ /* convert palette images to full RGB */
if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE)
png_set_expand (png_ptr);
/* send grayscale images to RGB too */
png_read_image (png_ptr, row_pointers);
png_read_end (png_ptr, info_ptr);
-
+
#ifdef PNG_SHOW_COMMENTS
/* ####
* I turn this off by default now, because the !%^@#!% comments
}
/* now instantiate */
- MAYBE_DEVMETH (XDEVICE (ii->device),
+ MAYBE_DEVMETH (XDEVICE (ii->device),
init_image_instance_from_eimage,
- (ii, width, height, unwind.eimage, dest_mask,
+ (ii, width, height, unwind.eimage, dest_mask,
instantiator, domain));
/* This will clean up everything else. */
if ((newidx > mem->len) || (newidx < 0))
return -1;
-
+
mem->index = newidx;
return newidx;
}
xzero (unwind);
record_unwind_protect (tiff_instantiate_unwind, make_opaque_ptr (&unwind));
-
+
/* set up error facilities */
if (setjmp (tiff_err_data.setjmp_buffer))
{
unwind.eimage = (unsigned char *) xmalloc (width * height * 3);
/* ### This is little more than proof-of-concept/function testing.
- It needs to be reimplimented via scanline reads for both memory
+ It needs to be reimplemented via scanline reads for both memory
compactness. */
raster = (uint32*) _TIFFmalloc (width * height * sizeof (uint32));
if (raster != NULL)
}
/* now instantiate */
- MAYBE_DEVMETH (XDEVICE (ii->device),
+ MAYBE_DEVMETH (XDEVICE (ii->device),
init_image_instance_from_eimage,
- (ii, width, height, unwind.eimage, dest_mask,
+ (ii, width, height, unwind.eimage, dest_mask,
instantiator, domain));
unbind_to (speccount, Qnil);
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
{
struct Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj);
- (markobj) (i->name);
+ markobj (i->name);
switch (IMAGE_INSTANCE_TYPE (i))
{
case IMAGE_TEXT:
- (markobj) (IMAGE_INSTANCE_TEXT_STRING (i));
+ markobj (IMAGE_INSTANCE_TEXT_STRING (i));
break;
case IMAGE_MONO_PIXMAP:
case IMAGE_COLOR_PIXMAP:
- (markobj) (IMAGE_INSTANCE_PIXMAP_FILENAME (i));
- (markobj) (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i));
- (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i));
- (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i));
- (markobj) (IMAGE_INSTANCE_PIXMAP_FG (i));
- (markobj) (IMAGE_INSTANCE_PIXMAP_BG (i));
+ markobj (IMAGE_INSTANCE_PIXMAP_FILENAME (i));
+ markobj (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i));
+ markobj (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i));
+ markobj (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i));
+ markobj (IMAGE_INSTANCE_PIXMAP_FG (i));
+ markobj (IMAGE_INSTANCE_PIXMAP_BG (i));
break;
case IMAGE_SUBWINDOW:
/* #### implement me */
}
static int
-image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+image_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (o1);
- struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (o2);
+ struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (obj1);
+ struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (obj2);
struct device *d1 = XDEVICE (i1->device);
struct device *d2 = XDEVICE (i2->device);
/* instantiate_image_instantiator() will abort if given an
image instance ... */
if (IMAGE_INSTANCEP (data))
- signal_simple_error ("image instances not allowed here", data);
+ signal_simple_error ("Image instances not allowed here", data);
image_validate (data);
dest_mask = decode_image_instance_type_list (dest_types);
data = normalize_image_instantiator (data, DEVICE_TYPE (XDEVICE (device)),
make_int (dest_mask));
GCPRO1 (data);
if (VECTORP (data) && EQ (XVECTOR_DATA (data)[0], Qinherit))
- signal_simple_error ("inheritance not allowed here", data);
+ signal_simple_error ("Inheritance not allowed here", data);
ii = instantiate_image_instantiator (device, device, data,
Qnil, Qnil, dest_mask);
RETURN_UNGCPRO (ii);
if (!NILP (file) && NILP (data))
{
Lisp_Object retval = MAYBE_LISP_CONTYPE_METH
- (decode_console_type(console_type, ERROR_ME),
+ (decode_console_type(console_type, ERROR_ME),
locate_pixmap_file, (file));
if (!NILP (retval))
else
return Fcons (file, Qnil); /* should have been file */
}
-
+
return Qnil;
}
Note that if we cannot generate any regular inline data, we
skip out. */
- file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
+ file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
console_type);
if (CONSP (file)) /* failure locating filename */
-- maybe return an error, or return Qnil.
*/
-#ifndef HAVE_X_WINDOWS
+#ifdef HAVE_X_WINDOWS
+#include <X11/Xlib.h>
+#else
#define XFree(data) free(data)
#endif
CONST char *filename_ext;
GET_C_STRING_FILENAME_DATA_ALLOCA (name, filename_ext);
- result = read_bitmap_data_from_file (filename_ext, &w, &h,
+ result = read_bitmap_data_from_file (filename_ext, &w, &h,
&data, xhot, yhot);
if (result == BitmapSuccess)
&& !NILP (file))
{
mask_file = MAYBE_LISP_CONTYPE_METH
- (decode_console_type(console_type, ERROR_ME),
+ (decode_console_type(console_type, ERROR_ME),
locate_pixmap_file, (concat2 (file, build_string ("Mask"))));
if (NILP (mask_file))
mask_file = MAYBE_LISP_CONTYPE_METH
- (decode_console_type(console_type, ERROR_ME),
+ (decode_console_type(console_type, ERROR_ME),
locate_pixmap_file, (concat2 (file, build_string ("msk"))));
}
{
Lisp_Object device= IMAGE_INSTANCE_DEVICE (XIMAGE_INSTANCE (image_instance));
- MAYBE_DEVMETH (XDEVICE (device),
+ MAYBE_DEVMETH (XDEVICE (device),
xbm_instantiate,
- (image_instance, instantiator, pointer_fg,
+ (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain));
}
Note that if we cannot generate any regular inline data, we
skip out. */
- file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
+ file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
console_type);
if (CONSP (file)) /* failure locating filename */
if (NILP (file) && !UNBOUNDP (color_symbols))
/* no conversion necessary */
RETURN_UNGCPRO (inst);
-
+
alist = tagged_vector_to_alist (inst);
if (!NILP (file))
alist = Fcons (Fcons (Q_file, file),
Fcons (Fcons (Q_data, data), alist));
}
-
+
if (UNBOUNDP (color_symbols))
{
color_symbols = evaluate_xpm_color_symbols ();
{
Lisp_Object device= IMAGE_INSTANCE_DEVICE (XIMAGE_INSTANCE (image_instance));
- MAYBE_DEVMETH (XDEVICE (device),
+ MAYBE_DEVMETH (XDEVICE (device),
xpm_instantiate,
- (image_instance, instantiator, pointer_fg,
+ (image_instance, instantiator, pointer_fg,
pointer_bg, dest_mask, domain));
}
{
struct Lisp_Specifier *image = XIMAGE_SPECIFIER (obj);
- ((markobj) (IMAGE_SPECIFIER_ATTACHEE (image)));
- ((markobj) (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image)));
+ markobj (IMAGE_SPECIFIER_ATTACHEE (image));
+ markobj (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image));
}
static Lisp_Object
pointer face.
*/
- subtable = make_lisp_hashtable (20,
- pointerp ? HASHTABLE_KEY_CAR_WEAK
- : HASHTABLE_KEY_WEAK,
- pointerp ? HASHTABLE_EQUAL
- : HASHTABLE_EQ);
+ subtable = make_lisp_hash_table (20,
+ pointerp ? HASH_TABLE_KEY_CAR_WEAK
+ : HASH_TABLE_KEY_WEAK,
+ pointerp ? HASH_TABLE_EQUAL
+ : HASH_TABLE_EQ);
Fputhash (make_int (dest_mask), subtable,
d->image_instance_cache);
instance = Qunbound;
{
struct Lisp_Glyph *glyph = XGLYPH (obj);
- ((markobj) (glyph->image));
- ((markobj) (glyph->contrib_p));
- ((markobj) (glyph->baseline));
- ((markobj) (glyph->face));
+ markobj (glyph->image);
+ markobj (glyph->contrib_p);
+ markobj (glyph->baseline);
+ markobj (glyph->face);
return glyph->plist;
}
This isn't concerned with "unspecified" attributes, that's what
#'glyph-differs-from-default-p is for. */
static int
-glyph_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+glyph_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Glyph *g1 = XGLYPH (o1);
- struct Lisp_Glyph *g2 = XGLYPH (o2);
+ struct Lisp_Glyph *g1 = XGLYPH (obj1);
+ struct Lisp_Glyph *g2 = XGLYPH (obj2);
depth++;
CHECK_GLYPH (glyph);
switch (XGLYPH_TYPE (glyph))
{
+ default: abort ();
case GLYPH_BUFFER: return Qbuffer;
case GLYPH_POINTER: return Qpointer;
case GLYPH_ICON: return Qicon;
- default:
- abort ();
- return Qnil; /* not reached */
}
}
for (elt = 0; elt < Dynarr_length (elements); elt++)
{
struct glyph_cachel *cachel = Dynarr_atp (elements, elt);
- ((markobj) (cachel->glyph));
+ markobj (cachel->glyph);
}
}
#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:
Bytecount old_gap_size;
/* If we have to get more space, get enough to last a while. We use
- a geometric progession that saves on realloc space. */
+ a geometric progression that saves on realloc space. */
increment += 2000 + ((BI_BUF_Z (buf) - BI_BUF_BEG (buf)) / 8);
if (increment > BUF_END_GAP_SIZE (buf))
}
}
-int
+Charcount
convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, Bytecount len,
Emchar *arr)
{
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; }
#ifdef USE_MINIMAL_TAGBITS
+# define Lisp_Type_Int_Bit (Lisp_Type_Int_Even & Lisp_Type_Int_Odd)
# define XUNMARK(x) DO_NOTHING
# define make_obj(vartype, x) ((Lisp_Object) (x))
-# define make_int(x) ((Lisp_Object) (((x) << INT_GCBITS) + 1))
-# define make_char(x) ((Lisp_Object) (((x) << GCBITS) + Lisp_Type_Char))
+# define make_int(x) ((Lisp_Object) (((x) << INT_GCBITS) | Lisp_Type_Int_Bit))
+# define make_char(x) ((Lisp_Object) (((x) << GCBITS) | Lisp_Type_Char))
# define VALMASK (((1UL << VALBITS) - 1UL) << GCTYPEBITS)
# define XTYPE(x) ((enum Lisp_Type) (((EMACS_UINT)(x)) & ~VALMASK))
# define XPNTRVAL(x) (x) /* This depends on Lisp_Type_Record == 0 */
# define GC_EQ(x,y) EQ (x,y)
# define XREALINT(x) ((x) >> INT_GCBITS)
# define XUINT(x) ((EMACS_UINT)(x) >> INT_GCBITS)
-# define INTP(x) ((EMACS_UINT)(x) & 1)
-# define Qzero ((Lisp_Object) 1UL)
+# define INTP(x) ((EMACS_UINT)(x) & Lisp_Type_Int_Bit)
#else /* !USE_MINIMAL_TAGBITS */
# define XREALINT(x) (((x) << INT_GCBITS) >> INT_GCBITS)
# define XUINT(x) ((EMACS_UINT) ((x) & VALMASK))
# define INTP(x) (XTYPE (x) == Lisp_Type_Int)
-# define Qzero ((Lisp_Object) Lisp_Type_Int)
#endif /* !USE_MINIMAL_TAGBITS */
-#define Qnull_pointer 0
+#define Qzero make_int (0)
+#define Qnull_pointer ((Lisp_Object) 0)
#define XGCTYPE(x) XTYPE(x)
#define EQ(x,y) ((x) == (y))
#define XSETINT(var, value) ((void) ((var) = make_int (value)))
#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);
#define _XEMACS_LISP_H_
/************************************************************************/
-/* general definitions */
+/* general definitions */
/************************************************************************/
/* We include the following generally useful header files so that you
# define DOESNT_RETURN void volatile
# define DECLARE_DOESNT_RETURN(decl) \
extern void volatile decl __attribute__ ((noreturn))
-# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \
+# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \
/* Should be able to state multiple independent __attribute__s, but \
the losing syntax doesn't work that way, and screws losing cpp */ \
extern void volatile decl \
# else
# define DOESNT_RETURN void volatile
# define DECLARE_DOESNT_RETURN(decl) extern void volatile decl
-# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \
+# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \
extern void volatile decl PRINTF_ARGS(str,idx)
# endif /* GNUC 2.5 */
# else
# define DOESNT_RETURN void
# define DECLARE_DOESNT_RETURN(decl) extern void decl
-# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \
+# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \
extern void decl PRINTF_ARGS(str,idx)
# endif /* GNUC */
#endif
#define ALIGN_PTR(ptr, unit) \
((void *) ALIGN_SIZE ((long) (ptr), unit))
-#ifdef QUANTIFY
-#include "quantify.h"
-#define QUANTIFY_START_RECORDING quantify_start_recording_data ()
-#define QUANTIFY_STOP_RECORDING quantify_stop_recording_data ()
-#else /* !QUANTIFY */
-#define QUANTIFY_START_RECORDING
-#define QUANTIFY_STOP_RECORDING
-#endif /* !QUANTIFY */
-
#ifndef DO_NOTHING
#define DO_NOTHING do {} while (0)
#endif
\f
/************************************************************************/
-/* typedefs */
+/* typedefs */
/************************************************************************/
/* We put typedefs here so that prototype declarations don't choke.
struct frame; /* "frame.h" */
struct window; /* "window.h" */
struct Lisp_Event; /* "events.h" */
+typedef struct Lisp_Event Lisp_Event;
struct Lisp_Face;
+typedef struct Lisp_Face Lisp_Face;
struct Lisp_Process; /* "process.c" */
+typedef struct Lisp_Process Lisp_Process;
struct stat; /* <sys/stat.h> */
struct Lisp_Color_Instance;
+typedef struct Lisp_Color_Instance Lisp_Color_Instance;
struct Lisp_Font_Instance;
+typedef struct Lisp_Font_Instance Lisp_Font_Instance;
struct Lisp_Image_Instance;
+typedef struct Lisp_Image_Instance Lisp_Image_Instance;
struct display_line;
struct redisplay_info;
struct window_mirror;
\f
/************************************************************************/
-/* Definition of Lisp_Object data type */
+/* Definition of Lisp_Object data type */
/************************************************************************/
#ifdef USE_MINIMAL_TAGBITS
enum Lisp_Type
{
- /* Integer. XINT(obj) is the integer value. */
- Lisp_Type_Int,
-
/* XRECORD_LHEADER (object) points to a struct lrecord_header
- lheader->implementation determines the type (and GC behaviour)
+ lheader->implementation determines the type (and GC behavior)
of the object. */
Lisp_Type_Record,
+ /* Integer. XINT(obj) is the integer value. */
+ Lisp_Type_Int,
+
#ifndef LRECORD_CONS
/* Cons. XCONS (object) points to a struct Lisp_Cons. */
Lisp_Type_Cons,
#endif /* USE_MINIMAL_TAGBITS */
-/* This should be the underlying type into which a Lisp_Object must fit.
- In a strict ANSI world, this must be `int', since ANSI says you can't
- use bitfields on any type other than `int'. However, on a machine
- where `int' and `long' are not the same size, this should be the
- longer of the two. (This also must be something into which a pointer
- to an arbitrary object will fit, modulo any DATA_SEG_BITS cruft.)
- */
-/* ### We should be using uintptr_t and SIZEOF_VOID_P here */
-#if (LONGBITS > INTBITS)
-# define EMACS_INT long
-# define EMACS_UINT unsigned long
-# define SIZEOF_EMACS_INT SIZEOF_LONG
-#else
-# define EMACS_INT int
-# define EMACS_UINT unsigned int
-# define SIZEOF_EMACS_INT SIZEOF_INT
+/* EMACS_INT is the underlying integral type into which a Lisp_Object must fit.
+ In particular, it must be large enough to contain a pointer.
+ config.h can override this, e.g. to use `long long' for bigger lisp ints. */
+
+#ifndef SIZEOF_EMACS_INT
+# define SIZEOF_EMACS_INT SIZEOF_VOID_P
+#endif
+
+#ifndef EMACS_INT
+# if SIZEOF_EMACS_INT == SIZEOF_LONG
+# define EMACS_INT long
+# elif SIZEOF_EMACS_INT == SIZEOF_INT
+# define EMACS_INT int
+# elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
+# define EMACS_INT long long
+# else
+# error Unable to determine suitable type for EMACS_INT
+# endif
+#endif
+
+#ifndef EMACS_UINT
+# define EMACS_UINT unsigned EMACS_INT
#endif
#define BITS_PER_EMACS_INT (SIZEOF_EMACS_INT * BITS_PER_CHAR)
\f
/************************************************************************/
-/* Definitions of basic Lisp objects */
+/* Definitions of basic Lisp objects */
/************************************************************************/
#include "lrecord.h"
-/********** unbound ***********/
+/*********** unbound ***********/
/* Qunbound is a special Lisp_Object (actually of type
symbol-value-forward), that can never be visible to
#endif
Lisp_Object car, cdr;
};
+typedef struct Lisp_Cons Lisp_Cons;
#if 0 /* FSFmacs */
/* Like a cons, but records info on where the text lives that it was read from */
#ifdef LRECORD_CONS
-DECLARE_LRECORD (cons, struct Lisp_Cons);
-#define XCONS(x) XRECORD (x, cons, struct Lisp_Cons)
+DECLARE_LRECORD (cons, Lisp_Cons);
+#define XCONS(x) XRECORD (x, cons, Lisp_Cons)
#define XSETCONS(x, p) XSETRECORD (x, p, cons)
#define CONSP(x) RECORDP (x, cons)
#define GC_CONSP(x) GC_RECORDP (x, cons)
#else /* ! LRECORD_CONS */
-DECLARE_NONRECORD (cons, Lisp_Type_Cons, struct Lisp_Cons);
-#define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, struct Lisp_Cons)
+DECLARE_NONRECORD (cons, Lisp_Type_Cons, Lisp_Cons);
+#define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, Lisp_Cons)
#define XSETCONS(c, p) XSETOBJ (c, Lisp_Type_Cons, p)
#define CONSP(x) (XTYPE (x) == Lisp_Type_Cons)
#define GC_CONSP(x) (XGCTYPE (x) == Lisp_Type_Cons)
#endif /* ! LRECORD_CONS */
+extern Lisp_Object Qnil;
+
#define NILP(x) EQ (x, Qnil)
#define GC_NILP(x) GC_EQ (x, Qnil)
#define XCAR(a) (XCONS (a)->car)
/* For a list that's known to be in valid list format --
will abort() if the list is not in valid format */
-#define LIST_LOOP(consvar, list) \
- for (consvar = list; !NILP (consvar); consvar = XCDR (consvar))
+#define LIST_LOOP(tail, list) \
+ for (tail = list; \
+ !NILP (tail); \
+ tail = XCDR (tail))
+
+#define LIST_LOOP_2(elt, list) \
+ Lisp_Object tail##elt; \
+ LIST_LOOP_3(elt, list, tail##elt)
+
+#define LIST_LOOP_3(elt, list, tail) \
+ for (tail = list; \
+ NILP (tail) ? \
+ 0 : (elt = XCAR (tail), 1); \
+ tail = XCDR (tail))
+
+#define GET_LIST_LENGTH(list, len) do { \
+ Lisp_Object GLL_tail; \
+ for (GLL_tail = list, len = 0; \
+ !NILP (GLL_tail); \
+ GLL_tail = XCDR (GLL_tail), ++len) \
+ DO_NOTHING; \
+} while (0)
+
+#define GET_EXTERNAL_LIST_LENGTH(list, len) \
+do { \
+ Lisp_Object GELL_elt, GELL_tail; \
+ EXTERNAL_LIST_LOOP_4 (GELL_elt, list, GELL_tail, len) \
+ ; \
+} while (0)
/* For a list that's known to be in valid list format, where we may
be deleting the current element out of the list --
will abort() if the list is not in valid format */
-#define LIST_LOOP_DELETING(consvar, nextconsvar, list) \
- for (consvar = list; \
- !NILP (consvar) ? (nextconsvar = XCDR (consvar), 1) : 0; \
+#define LIST_LOOP_DELETING(consvar, nextconsvar, list) \
+ for (consvar = list; \
+ !NILP (consvar) ? (nextconsvar = XCDR (consvar), 1) :0; \
consvar = nextconsvar)
+/* Delete all elements of external list LIST
+ satisfying CONDITION, an expression referring to variable ELT */
+#define EXTERNAL_LIST_LOOP_DELETE_IF(elt, list, condition) do { \
+ Lisp_Object prev_tail_##list = Qnil; \
+ Lisp_Object tail_##list; \
+ int len_##list; \
+ EXTERNAL_LIST_LOOP_4 (elt, list, tail_##list, len_##list) \
+ { \
+ if (condition) \
+ { \
+ if (NILP (prev_tail_##list)) \
+ list = XCDR (tail_##list); \
+ else \
+ XCDR (prev_tail_##list) = XCDR (tail_##list); \
+ /* Keep tortoise from ever passing hare. */ \
+ len_##list = 0; \
+ } \
+ else \
+ prev_tail_##list = tail_##list; \
+ } \
+} while (0)
+
+/* Delete all elements of true non-circular list LIST
+ satisfying CONDITION, an expression referring to variable ELT */
+#define LIST_LOOP_DELETE_IF(elt, list, condition) do { \
+ Lisp_Object prev_tail_##list = Qnil; \
+ Lisp_Object tail_##list; \
+ LIST_LOOP_3 (elt, list, tail_##list) \
+ { \
+ if (condition) \
+ { \
+ if (NILP (prev_tail_##list)) \
+ list = XCDR (tail_##list); \
+ else \
+ XCDR (prev_tail_##list) = XCDR (tail_##list); \
+ } \
+ else \
+ prev_tail_##list = tail_##list; \
+ } \
+} while (0)
+
/* For a list that may not be in valid list format --
will signal an error if the list is not in valid format */
-#define EXTERNAL_LIST_LOOP(consvar, listp) \
- for (consvar = listp; !NILP (consvar); consvar = XCDR (consvar)) \
- if (!CONSP (consvar)) \
- signal_simple_error ("Invalid list format", listp); \
+#define EXTERNAL_LIST_LOOP(tail, list) \
+ for (tail = list; !NILP (tail); tail = XCDR (tail)) \
+ if (!CONSP (tail)) \
+ signal_malformed_list_error (list); \
else
-extern Lisp_Object Qnil;
-INLINE int TRUE_LIST_P (Lisp_Object object);
-INLINE int
-TRUE_LIST_P (Lisp_Object object)
-{
- while (CONSP (object))
- object = XCDR (object);
- return NILP (object);
-}
+/* The following macros are for traversing lisp lists.
+ Signal an error if LIST is not properly acyclic and nil-terminated.
+
+ Use tortoise/hare algorithm to check for cycles, but only if it
+ looks like the list is getting too long. Not only is the hare
+ faster than the tortoise; it even gets a head start! */
+
+/* Optimized and safe macros for looping over external lists. */
+#define CIRCULAR_LIST_SUSPICION_LENGTH 1024
+
+#define EXTERNAL_LIST_LOOP_1(list) \
+Lisp_Object ELL1_elt, ELL1_hare, ELL1_tortoise; \
+int ELL1_len; \
+EXTERNAL_LIST_LOOP_6(ELL1_elt, list, ELL1_len, ELL1_hare, \
+ ELL1_tortoise, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_LIST_LOOP_2(elt, list) \
+Lisp_Object hare_##elt, tortoise_##elt; \
+int len_##elt; \
+EXTERNAL_LIST_LOOP_6(elt, list, len_##elt, hare_##elt, \
+ tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_LIST_LOOP_3(elt, list, tail) \
+Lisp_Object tortoise_##elt; \
+int len_##elt; \
+EXTERNAL_LIST_LOOP_6(elt, list, len_##elt, tail, \
+ tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_LIST_LOOP_4(elt, list, tail, len) \
+Lisp_Object tortoise_##elt; \
+EXTERNAL_LIST_LOOP_6(elt, list, len, tail, \
+ tortoise_##elt, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+
+#define EXTERNAL_LIST_LOOP_6(elt, list, len, hare, \
+ tortoise, suspicion_length) \
+ for (tortoise = hare = list, len = 0; \
+ \
+ (CONSP (hare) ? ((elt = XCAR (hare)), 1) : \
+ (NILP (hare) ? 0 : \
+ (signal_malformed_list_error (list), 0))); \
+ \
+ hare = XCDR (hare), \
+ ((++len < suspicion_length) ? \
+ ((void) 0) : \
+ (((len & 1) ? \
+ ((void) (tortoise = XCDR (tortoise))) : \
+ ((void) 0)) \
+ , \
+ (EQ (hare, tortoise) ? \
+ ((void) signal_circular_list_error (list)) : \
+ ((void) 0)))))
+
+
+
+/* Optimized and safe macros for looping over external alists. */
+#define EXTERNAL_ALIST_LOOP_4(elt, elt_car, elt_cdr, list) \
+Lisp_Object hare_##elt, tortoise_##elt; \
+int len_##elt; \
+EXTERNAL_ALIST_LOOP_8 (elt, elt_car, elt_cdr, list, \
+ len_##elt, hare_##elt, tortoise_##elt, \
+ CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_ALIST_LOOP_5(elt, elt_car, elt_cdr, list, tail) \
+Lisp_Object tortoise_##elt; \
+int len_##elt; \
+EXTERNAL_ALIST_LOOP_8(elt, elt_car, elt_cdr, list, \
+ len_##elt, tail, tortoise_##elt, \
+ CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_ALIST_LOOP_6(elt, elt_car, elt_cdr, list, tail, len) \
+Lisp_Object tortoise_##elt; \
+EXTERNAL_ALIST_LOOP_8(elt, elt_car, elt_cdr, list, \
+ len, tail, tortoise_##elt, \
+ CIRCULAR_LIST_SUSPICION_LENGTH)
+
+
+#define EXTERNAL_ALIST_LOOP_8(elt, elt_car, elt_cdr, list, len, hare, \
+ tortoise, suspicion_length) \
+EXTERNAL_LIST_LOOP_6(elt, list, len, hare, tortoise, suspicion_length) \
+ if (CONSP (elt) ? (elt_car = XCAR (elt), elt_cdr = XCDR (elt), 0) :1) \
+ continue; \
+ else
-#define CHECK_TRUE_LIST(object) do { \
- if (!TRUE_LIST_P (object)) \
- dead_wrong_type_argument (Qtrue_list_p, object); \
-} while (0)
+
+/* Optimized and safe macros for looping over external property lists. */
+#define EXTERNAL_PROPERTY_LIST_LOOP_3(key, value, list) \
+Lisp_Object key, value, hare_##key, tortoise_##key; \
+int len_##key; \
+EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len_##key, hare_##key,\
+ tortoise_##key, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_PROPERTY_LIST_LOOP_4(key, value, list, tail) \
+Lisp_Object key, value, tail, tortoise_##key; \
+int len_##key; \
+EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len_##key, tail, \
+ tortoise_##key, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+#define EXTERNAL_PROPERTY_LIST_LOOP_5(key, value, list, tail, len) \
+Lisp_Object key, value, tail, tortoise_##key; \
+int len; \
+EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len, tail, \
+ tortoise_##key, CIRCULAR_LIST_SUSPICION_LENGTH)
+
+
+#define EXTERNAL_PROPERTY_LIST_LOOP_7(key, value, list, len, hare, \
+ tortoise, suspicion_length) \
+ for (tortoise = hare = list, len = 0; \
+ \
+ ((CONSP (hare) && \
+ (key = XCAR (hare), \
+ hare = XCDR (hare), \
+ CONSP (hare))) ? \
+ (value = XCAR (hare), 1) : \
+ (NILP (hare) ? 0 : \
+ (signal_malformed_property_list_error (list), 0))); \
+ \
+ hare = XCDR (hare), \
+ ((++len < suspicion_length) ? \
+ ((void) 0) : \
+ (((len & 1) ? \
+ ((void) (tortoise = XCDR (XCDR (tortoise)))) : \
+ ((void) 0)) \
+ , \
+ (EQ (hare, tortoise) ? \
+ ((void) signal_circular_property_list_error (list)) : \
+ ((void) 0)))))
/* For a property list (alternating keywords/values) that may not be
in valid list format -- will signal an error if the list is not in
valid format. CONSVAR is used to keep track of the iterations
- without modifying LISTP.
+ without modifying PLIST.
We have to be tricky to still keep the same C format.*/
-#define EXTERNAL_PROPERTY_LIST_LOOP(consvar, keyword, value, listp) \
- for (consvar = listp; \
- (CONSP (consvar) && CONSP (XCDR (consvar)) ? \
- (keyword = XCAR (consvar), value = XCAR (XCDR (consvar))) : \
- (keyword = Qunbound, value = Qunbound)), \
- !NILP (consvar); \
- consvar = XCDR (XCDR (consvar))) \
- if (UNBOUNDP (keyword)) \
- signal_simple_error ("Invalid property list format", listp); \
+#define EXTERNAL_PROPERTY_LIST_LOOP(tail, key, value, plist) \
+ for (tail = plist; \
+ (CONSP (tail) && CONSP (XCDR (tail)) ? \
+ (key = XCAR (tail), value = XCAR (XCDR (tail))) : \
+ (key = Qunbound, value = Qunbound)), \
+ !NILP (tail); \
+ tail = XCDR (XCDR (tail))) \
+ if (UNBOUNDP (key)) \
+ Fsignal (Qmalformed_property_list, list1 (plist)); \
else
+#define PROPERTY_LIST_LOOP(tail, key, value, plist) \
+ for (tail = plist; \
+ NILP (tail) ? 0 : \
+ (key = XCAR (tail), tail = XCDR (tail), \
+ value = XCAR (tail), tail = XCDR (tail), 1); \
+ )
+
+/* Return 1 if LIST is properly acyclic and nil-terminated, else 0. */
+INLINE int TRUE_LIST_P (Lisp_Object object);
+INLINE int
+TRUE_LIST_P (Lisp_Object object)
+{
+ Lisp_Object hare, tortoise;
+ int len;
+
+ for (hare = tortoise = object, len = 0;
+ CONSP (hare);
+ hare = XCDR (hare), len++)
+ {
+ if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
+ continue;
+
+ if (len & 1)
+ tortoise = XCDR (tortoise);
+ else if (EQ (hare, tortoise))
+ return 0;
+ }
+
+ return NILP (hare);
+}
+
+/* Signal an error if LIST is not properly acyclic and nil-terminated. */
+#define CHECK_TRUE_LIST(list) do { \
+ Lisp_Object CTL_list = (list); \
+ Lisp_Object CTL_hare, CTL_tortoise; \
+ int CTL_len; \
+ \
+ for (CTL_hare = CTL_tortoise = CTL_list, CTL_len = 0; \
+ CONSP (CTL_hare); \
+ CTL_hare = XCDR (CTL_hare), CTL_len++) \
+ { \
+ if (CTL_len < CIRCULAR_LIST_SUSPICION_LENGTH) \
+ continue; \
+ \
+ if (CTL_len & 1) \
+ CTL_tortoise = XCDR (CTL_tortoise); \
+ else if (EQ (CTL_hare, CTL_tortoise)) \
+ Fsignal (Qcircular_list, list1 (CTL_list)); \
+ } \
+ \
+ if (! NILP (CTL_hare)) \
+ signal_malformed_list_error (CTL_list); \
+} while (0)
+
/*********** string ***********/
-/* In a string or vector, the sign bit of the `size' is the gc mark bit */
+/* In a string, the markbit of the plist is used as the gc mark bit */
-/* (The size and data fields have underscores prepended to catch old
- code that attempts to reference the fields directly) */
struct Lisp_String
{
#ifdef LRECORD_STRING
struct lrecord_header lheader;
#endif
- Bytecount _size;
- Bufbyte *_data;
+ Bytecount size;
+ Bufbyte *data;
Lisp_Object plist;
};
+typedef struct Lisp_String Lisp_String;
#ifdef LRECORD_STRING
-DECLARE_LRECORD (string, struct Lisp_String);
-#define XSTRING(x) XRECORD (x, string, struct Lisp_String)
+DECLARE_LRECORD (string, Lisp_String);
+#define XSTRING(x) XRECORD (x, string, Lisp_String)
#define XSETSTRING(x, p) XSETRECORD (x, p, string)
#define STRINGP(x) RECORDP (x, string)
#define GC_STRINGP(x) GC_RECORDP (x, string)
#else /* ! LRECORD_STRING */
-DECLARE_NONRECORD (string, Lisp_Type_String, struct Lisp_String);
-#define XSTRING(x) XNONRECORD (x, string, Lisp_Type_String, struct Lisp_String)
+DECLARE_NONRECORD (string, Lisp_Type_String, Lisp_String);
+#define XSTRING(x) XNONRECORD (x, string, Lisp_Type_String, Lisp_String)
#define XSETSTRING(x, p) XSETOBJ (x, Lisp_Type_String, p)
#define STRINGP(x) (XTYPE (x) == Lisp_Type_String)
#define GC_STRINGP(x) (XGCTYPE (x) == Lisp_Type_String)
#endif /* not MULE */
-#define string_length(s) ((s)->_size)
+#define string_length(s) ((s)->size)
#define XSTRING_LENGTH(s) string_length (XSTRING (s))
#define XSTRING_CHAR_LENGTH(s) string_char_length (XSTRING (s))
-#define string_data(s) ((s)->_data + 0)
+#define string_data(s) ((s)->data + 0)
#define XSTRING_DATA(s) string_data (XSTRING (s))
-#define string_byte(s, i) ((s)->_data[i] + 0)
+#define string_byte(s, i) ((s)->data[i] + 0)
#define XSTRING_BYTE(s, i) string_byte (XSTRING (s), i)
-#define string_byte_addr(s, i) (&((s)->_data[i]))
-#define set_string_length(s, len) ((void) ((s)->_size = (len)))
-#define set_string_data(s, ptr) ((void) ((s)->_data = (ptr)))
-#define set_string_byte(s, i, c) ((void) ((s)->_data[i] = (c)))
+#define string_byte_addr(s, i) (&((s)->data[i]))
+#define set_string_length(s, len) ((void) ((s)->size = (len)))
+#define set_string_data(s, ptr) ((void) ((s)->data = (ptr)))
+#define set_string_byte(s, i, c) ((void) ((s)->data[i] = (c)))
-void resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta);
+void resize_string (Lisp_String *s, Bytecount pos, Bytecount delta);
#ifdef MULE
-INLINE Charcount string_char_length (struct Lisp_String *s);
+INLINE Charcount string_char_length (Lisp_String *s);
INLINE Charcount
-string_char_length (struct Lisp_String *s)
+string_char_length (Lisp_String *s)
{
return bytecount_to_charcount (string_data (s), string_length (s));
}
# define string_char(s, i) charptr_emchar_n (string_data (s), i)
# define string_char_addr(s, i) charptr_n_addr (string_data (s), i)
-void set_string_char (struct Lisp_String *s, Charcount i, Emchar c);
+void set_string_char (Lisp_String *s, Charcount i, Emchar c);
#else /* not MULE */
/* struct Lisp_Vector *next; */
Lisp_Object contents[1];
};
+typedef struct Lisp_Vector Lisp_Vector;
#ifdef LRECORD_VECTOR
-DECLARE_LRECORD (vector, struct Lisp_Vector);
-#define XVECTOR(x) XRECORD (x, vector, struct Lisp_Vector)
+DECLARE_LRECORD (vector, Lisp_Vector);
+#define XVECTOR(x) XRECORD (x, vector, Lisp_Vector)
#define XSETVECTOR(x, p) XSETRECORD (x, p, vector)
#define VECTORP(x) RECORDP (x, vector)
#define GC_VECTORP(x) GC_RECORDP (x, vector)
#else
-DECLARE_NONRECORD (vector, Lisp_Type_Vector, struct Lisp_Vector);
-#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Type_Vector, struct Lisp_Vector)
+DECLARE_NONRECORD (vector, Lisp_Type_Vector, Lisp_Vector);
+#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Type_Vector, Lisp_Vector)
#define XSETVECTOR(x, p) XSETOBJ (x, Lisp_Type_Vector, p)
#define VECTORP(x) (XTYPE (x) == Lisp_Type_Vector)
#define GC_VECTORP(x) (XGCTYPE (x) == Lisp_Type_Vector)
{
struct lrecord_header lheader;
Lisp_Object next;
- long size;
+ size_t size;
unsigned long bits[1];
};
+typedef struct Lisp_Bit_Vector Lisp_Bit_Vector;
-DECLARE_LRECORD (bit_vector, struct Lisp_Bit_Vector);
-#define XBIT_VECTOR(x) XRECORD (x, bit_vector, struct Lisp_Bit_Vector)
+DECLARE_LRECORD (bit_vector, Lisp_Bit_Vector);
+#define XBIT_VECTOR(x) XRECORD (x, bit_vector, Lisp_Bit_Vector)
#define XSETBIT_VECTOR(x, p) XSETRECORD (x, p, bit_vector)
#define BIT_VECTORP(x) RECORDP (x, bit_vector)
#define GC_BIT_VECTORP(x) GC_RECORDP (x, bit_vector)
#define bit_vector_length(v) ((v)->size)
#define bit_vector_next(v) ((v)->next)
-INLINE int bit_vector_bit (struct Lisp_Bit_Vector *v, int i);
+INLINE int bit_vector_bit (Lisp_Bit_Vector *v, int i);
INLINE int
-bit_vector_bit (struct Lisp_Bit_Vector *v, int i)
+bit_vector_bit (Lisp_Bit_Vector *v, int i)
{
unsigned int ui = (unsigned int) i;
& 1);
}
-INLINE void set_bit_vector_bit (struct Lisp_Bit_Vector *v, int i, int value);
+INLINE void set_bit_vector_bit (Lisp_Bit_Vector *v, int i, int value);
INLINE void
-set_bit_vector_bit (struct Lisp_Bit_Vector *v, int i, int value)
+set_bit_vector_bit (Lisp_Bit_Vector *v, int i, int value)
{
unsigned int ui = (unsigned int) i;
if (value)
- (v)->bits[ui >> LONGBITS_LOG2] |= (1 << (ui & (LONGBITS_POWER_OF_2 - 1)));
+ (v)->bits[ui >> LONGBITS_LOG2] |= (1U << (ui & (LONGBITS_POWER_OF_2 - 1)));
else
- (v)->bits[ui >> LONGBITS_LOG2] &= ~(1 << (ui & (LONGBITS_POWER_OF_2 - 1)));
+ (v)->bits[ui >> LONGBITS_LOG2] &= ~(1U << (ui & (LONGBITS_POWER_OF_2 - 1)));
}
/* Number of longs required to hold LEN bits */
Lisp_Object obarray;
Lisp_Object plist;
};
+typedef struct Lisp_Symbol Lisp_Symbol;
#define SYMBOL_IS_KEYWORD(sym) (string_byte (XSYMBOL(sym)->name, 0) == ':')
#define KEYWORDP(obj) (SYMBOLP (obj) && SYMBOL_IS_KEYWORD (obj))
#ifdef LRECORD_SYMBOL
-DECLARE_LRECORD (symbol, struct Lisp_Symbol);
-#define XSYMBOL(x) XRECORD (x, symbol, struct Lisp_Symbol)
+DECLARE_LRECORD (symbol, Lisp_Symbol);
+#define XSYMBOL(x) XRECORD (x, symbol, Lisp_Symbol)
#define XSETSYMBOL(x, p) XSETRECORD (x, p, symbol)
#define SYMBOLP(x) RECORDP (x, symbol)
#define GC_SYMBOLP(x) GC_RECORDP (x, symbol)
#else
-DECLARE_NONRECORD (symbol, Lisp_Type_Symbol, struct Lisp_Symbol);
-#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Type_Symbol, struct Lisp_Symbol)
+DECLARE_NONRECORD (symbol, Lisp_Type_Symbol, Lisp_Symbol);
+#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Type_Symbol, Lisp_Symbol)
#define XSETSYMBOL(s, p) XSETOBJ ((s), Lisp_Type_Symbol, (p))
#define SYMBOLP(x) (XTYPE (x) == Lisp_Type_Symbol)
#define GC_SYMBOLP(x) (XGCTYPE (x) == Lisp_Type_Symbol)
CONST char *name;
lisp_fn_t subr_fn;
};
+typedef struct Lisp_Subr Lisp_Subr;
-DECLARE_LRECORD (subr, struct Lisp_Subr);
-#define XSUBR(x) XRECORD (x, subr, struct Lisp_Subr)
+DECLARE_LRECORD (subr, Lisp_Subr);
+#define XSUBR(x) XRECORD (x, subr, Lisp_Subr)
#define XSETSUBR(x, p) XSETRECORD (x, p, subr)
#define SUBRP(x) RECORDP (x, subr)
#define GC_SUBRP(x) GC_RECORDP (x, subr)
Memind memind;
char insertion_type;
};
+typedef struct Lisp_Marker Lisp_Marker;
-DECLARE_LRECORD (marker, struct Lisp_Marker);
-#define XMARKER(x) XRECORD (x, marker, struct Lisp_Marker)
+DECLARE_LRECORD (marker, Lisp_Marker);
+#define XMARKER(x) XRECORD (x, marker, Lisp_Marker)
#define XSETMARKER(x, p) XSETRECORD (x, p, marker)
#define MARKERP(x) RECORDP (x, marker)
#define GC_MARKERP(x) GC_RECORDP (x, marker)
#ifdef LISP_FLOAT_TYPE
-/* Note: the 'unused__next__' field exists only to ensure that the
+/* Note: the 'unused_next_' field exists only to ensure that the
`next' pointer fits within the structure, for the purposes of the
free list. This makes a difference in the unlikely case of
sizeof(double) being smaller than sizeof(void *). */
struct Lisp_Float
{
struct lrecord_header lheader;
- union { double d; struct Lisp_Float *unused__next__; } data;
+ union { double d; struct Lisp_Float *unused_next_; } data;
};
+typedef struct Lisp_Float Lisp_Float;
-DECLARE_LRECORD (float, struct Lisp_Float);
-#define XFLOAT(x) XRECORD (x, float, struct Lisp_Float)
+DECLARE_LRECORD (float, Lisp_Float);
+#define XFLOAT(x) XRECORD (x, float, Lisp_Float)
#define XSETFLOAT(x, p) XSETRECORD (x, p, float)
#define FLOATP(x) RECORDP (x, float)
#define GC_FLOATP(x) GC_RECORDP (x, float)
#define CONCHECK_FLOAT(x) CONCHECK_RECORD (x, float)
#define float_data(f) ((f)->data.d)
+#define XFLOAT_DATA(x) float_data (XFLOAT (x))
#define XFLOATINT(n) extract_float (n)
x = wrong_type_argument (Qnumberp, x); \
} while (0)
-/* These are always continuable because they change their arguments
- even when no error is signalled. */
-
-#define CHECK_INT_OR_FLOAT_COERCE_MARKER(x) do { \
- if (INT_OR_FLOATP (x)) \
- ; \
- else if (MARKERP (x)) \
- x = make_int (marker_position (x)); \
- else \
- x = wrong_type_argument (Qnumber_or_marker_p, x); \
-} while (0)
-
-#define CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER(x) do { \
- if (INT_OR_FLOATP (x)) \
- ; \
- else if (CHARP (x)) \
- x = make_int (XCHAR (x)); \
- else if (MARKERP (x)) \
- x = make_int (marker_position (x)); \
- else \
- x = wrong_type_argument (Qnumber_char_or_marker_p, x); \
-} while (0)
-
# define INT_OR_FLOATP(x) (INTP (x) || FLOATP (x))
# define GC_INT_OR_FLOATP(x) (GC_INTP (x) || GC_FLOATP (x))
#define XFLOATINT(n) XINT(n)
#define CHECK_INT_OR_FLOAT CHECK_INT
#define CONCHECK_INT_OR_FLOAT CONCHECK_INT
-#define CHECK_INT_OR_FLOAT_COERCE_MARKER CHECK_INT_COERCE_MARKER
-#define CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER \
- CHECK_INT_COERCE_CHAR_OR_MARKER
#define INT_OR_FLOATP(x) (INTP (x))
# define GC_INT_OR_FLOATP(x) (GC_INTP (x))
x = wrong_type_argument (Qinteger_char_or_marker_p, x); \
} while (0)
+
/*********** pure space ***********/
#define CHECK_IMPURE(obj) \
\f
/************************************************************************/
-/* Definitions of primitive Lisp functions and variables */
+/* Definitions of primitive Lisp functions and variables */
/************************************************************************/
valid in a C identifier, with an "F" prepended.
The name of the C constant structure that records information
on this function for internal use is "S" concatenated with Fname.
- `minargs' should be a number, the minimum number of arguments allowed.
- `maxargs' should be a number, the maximum number of arguments allowed,
+ `min_args' should be a number, the minimum number of arguments allowed.
+ `max_args' should be a number, the maximum number of arguments allowed,
or else MANY or UNEVALLED.
MANY means pass a vector of evaluated arguments,
in the form of an integer number-of-arguments
Lisp_Object,Lisp_Object,Lisp_Object
#define EXFUN_MANY int, Lisp_Object*
#define EXFUN_UNEVALLED Lisp_Object
-#define EXFUN(sym, maxargs) Lisp_Object sym (EXFUN_##maxargs)
+#define EXFUN(sym, max_args) Lisp_Object sym (EXFUN_##max_args)
#define SUBR_MAX_ARGS 8
#define MANY -2
# define subr_lheader_initializer { lrecord_subr }
#endif
-#define DEFUN(lname, Fname, minargs, maxargs, prompt, arglist) \
- Lisp_Object Fname (EXFUN_##maxargs); \
+#define DEFUN(lname, Fname, min_args, max_args, prompt, arglist) \
+ Lisp_Object Fname (EXFUN_##max_args); \
static struct Lisp_Subr S##Fname = { subr_lheader_initializer, \
- minargs, maxargs, prompt, 0, lname, (lisp_fn_t) Fname }; \
- Lisp_Object Fname (DEFUN_##maxargs arglist)
+ min_args, max_args, prompt, 0, lname, (lisp_fn_t) Fname }; \
+ Lisp_Object Fname (DEFUN_##max_args arglist)
/* Heavy ANSI C preprocessor hackery to get DEFUN to declare a
- prototype that matches maxargs, and add the obligatory
+ prototype that matches max_args, and add the obligatory
`Lisp_Object' type declaration to the formal C arguments. */
#define DEFUN_MANY(named_int, named_Lisp_Object) named_int, named_Lisp_Object
#define DEFUN_7(a,b,c,d,e,f,g) DEFUN_6(a,b,c,d,e,f), Lisp_Object g
#define DEFUN_8(a,b,c,d,e,f,g,h) DEFUN_7(a,b,c,d,e,f,g),Lisp_Object h
-/* WARNING: If you add defines here for higher values of maxargs,
- make sure to also fix the clauses in inline_funcall_fn(),
+/* WARNING: If you add defines here for higher values of max_args,
+ make sure to also fix the clauses in PRIMITIVE_FUNCALL(),
and change the define of SUBR_MAX_ARGS above. */
#include "symeval.h"
-/* Depth of special binding/unwind-protect stack. Use as arg to `unbind_to' */
-int specpdl_depth (void);
+/* `specpdl' is the special binding/unwind-protect stack.
+
+ Knuth says (see the Jargon File):
+ At MIT, `pdl' [abbreviation for `Push Down List'] used to
+ be a more common synonym for `stack'.
+ Everywhere else `stack' seems to be the preferred term.
+
+ specpdl_depth is the current depth of `specpdl'.
+ Save this for use later as arg to `unbind_to'. */
+extern int specpdl_depth_counter;
+#define specpdl_depth() specpdl_depth_counter
\f
/************************************************************************/
-/* Checking for QUIT */
+/* Checking for QUIT */
/************************************************************************/
/* Asynchronous events set something_happened, and then are processed
\f
/************************************************************************/
-/* hashing */
+/* hashing */
/************************************************************************/
/* #### for a 64-bit machine, we should substitute a prime just over 2^32 */
#define HASH8(a,b,c,d,e,f,g,h) (GOOD_HASH * HASH7 (a,b,c,d,e,f,g) + (h))
#define HASH9(a,b,c,d,e,f,g,h,i) (GOOD_HASH * HASH8 (a,b,c,d,e,f,g,h) + (i))
-/* Enough already! */
-
#define LISP_HASH(obj) ((unsigned long) LISP_TO_VOID (obj))
unsigned long string_hash (CONST void *xv);
unsigned long memory_hash (CONST void *xv, size_t size);
\f
/************************************************************************/
-/* String translation */
+/* String translation */
/************************************************************************/
#ifdef I18N3
\f
/************************************************************************/
-/* Garbage collection / GC-protection */
+/* Garbage collection / GC-protection */
/************************************************************************/
/* number of bytes of structure consed since last GC */
#else /* ! DEBUG_GCPRO */
-#define GCPRO1(varname) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \
- gcprolist = &gcpro1; }
-
-#define GCPRO2(varname1, varname2) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcprolist = &gcpro2; }
-
-#define GCPRO3(varname1, varname2, varname3) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcprolist = &gcpro3; }
-
-#define GCPRO4(varname1, varname2, varname3, varname4) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcprolist = &gcpro4; }
-
-#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \
- {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \
- gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \
- gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \
- gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \
- gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \
- gcprolist = &gcpro5; }
-
-#define UNGCPRO (gcprolist = gcpro1.next)
-
-#define NGCPRO1(varname) \
- {ngcpro1.next = gcprolist; ngcpro1.var = &varname; ngcpro1.nvars = 1; \
- gcprolist = &ngcpro1; }
-
-#define NGCPRO2(varname1, varname2) \
- {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \
- ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \
- gcprolist = &ngcpro2; }
-
-#define NGCPRO3(varname1, varname2, varname3) \
- {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \
- ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \
- ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \
- gcprolist = &ngcpro3; }
-
-#define NGCPRO4(varname1, varname2, varname3, varname4) \
- {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \
- ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \
- ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \
- ngcpro4.next = &ngcpro3; ngcpro4.var = &varname4; ngcpro4.nvars = 1; \
- gcprolist = &ngcpro4; }
-
-#define NGCPRO5(varname1, varname2, varname3, varname4, varname5) \
- {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \
- ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \
- ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \
- ngcpro4.next = &ngcpro3; ngcpro4.var = &varname4; ngcpro4.nvars = 1; \
- ngcpro5.next = &ngcpro4; ngcpro5.var = &varname5; ngcpro5.nvars = 1; \
- gcprolist = &ngcpro5; }
-
-#define NUNGCPRO (gcprolist = ngcpro1.next)
-
-#define NNGCPRO1(varname) \
- {nngcpro1.next = gcprolist; nngcpro1.var = &varname; nngcpro1.nvars = 1; \
- gcprolist = &nngcpro1; }
-
-#define NNGCPRO2(varname1, varname2) \
- {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \
- nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \
- gcprolist = &nngcpro2; }
-
-#define NNGCPRO3(varname1, varname2, varname3) \
- {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \
- nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \
- nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \
- gcprolist = &nngcpro3; }
-
-#define NNGCPRO4(varname1, varname2, varname3, varname4) \
- {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \
- nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \
- nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \
- nngcpro4.next = &nngcpro3; nngcpro4.var = &varname4; nngcpro4.nvars = 1; \
- gcprolist = &nngcpro4; }
-
-#define NNGCPRO5(varname1, varname2, varname3, varname4, varname5) \
- {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \
- nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \
- nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \
- nngcpro4.next = &nngcpro3; nngcpro4.var = &varname4; nngcpro4.nvars = 1; \
- nngcpro5.next = &nngcpro4; nngcpro5.var = &varname5; nngcpro5.nvars = 1; \
- gcprolist = &nngcpro5; }
-
-#define NNUNGCPRO (gcprolist = nngcpro1.next)
+#define GCPRO1(var1) ((void) ( \
+ gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \
+ gcprolist = &gcpro1 ))
+
+#define GCPRO2(var1, var2) ((void) ( \
+ gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \
+ gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \
+ gcprolist = &gcpro2 ))
+
+#define GCPRO3(var1, var2, var3) ((void) ( \
+ gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \
+ gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \
+ gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \
+ gcprolist = &gcpro3 ))
+
+#define GCPRO4(var1, var2, var3, var4) ((void) ( \
+ gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \
+ gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \
+ gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \
+ gcpro4.next = &gcpro3, gcpro4.var = &var4, gcpro4.nvars = 1, \
+ gcprolist = &gcpro4 ))
+
+#define GCPRO5(var1, var2, var3, var4, var5) \
+ ((void) ( \
+ gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \
+ gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \
+ gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \
+ gcpro4.next = &gcpro3, gcpro4.var = &var4, gcpro4.nvars = 1, \
+ gcpro5.next = &gcpro4, gcpro5.var = &var5, gcpro5.nvars = 1, \
+ gcprolist = &gcpro5 ))
+
+#define UNGCPRO ((void) (gcprolist = gcpro1.next))
+
+#define NGCPRO1(var1) ((void) ( \
+ ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \
+ gcprolist = &ngcpro1 ))
+
+#define NGCPRO2(var1, var2) ((void) ( \
+ ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \
+ ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \
+ gcprolist = &ngcpro2 ))
+
+#define NGCPRO3(var1, var2, var3) ((void) ( \
+ ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \
+ ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \
+ ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \
+ gcprolist = &ngcpro3 ))
+
+#define NGCPRO4(var1, var2, var3, var4) ((void) ( \
+ ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \
+ ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \
+ ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \
+ ngcpro4.next = &ngcpro3, ngcpro4.var = &var4, ngcpro4.nvars = 1, \
+ gcprolist = &ngcpro4 ))
+
+#define NGCPRO5(var1, var2, var3, var4, var5) \
+ ((void) ( \
+ ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \
+ ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \
+ ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \
+ ngcpro4.next = &ngcpro3, ngcpro4.var = &var4, ngcpro4.nvars = 1, \
+ ngcpro5.next = &ngcpro4, ngcpro5.var = &var5, ngcpro5.nvars = 1, \
+ gcprolist = &ngcpro5 ))
+
+#define NUNGCPRO ((void) (gcprolist = ngcpro1.next))
+
+#define NNGCPRO1(var1) ((void) ( \
+ nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \
+ gcprolist = &nngcpro1 ))
+
+#define NNGCPRO2(var1, var2) ((void) ( \
+ nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \
+ nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \
+ gcprolist = &nngcpro2 ))
+
+#define NNGCPRO3(var1, var2, var3) ((void) ( \
+ nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \
+ nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \
+ nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \
+ gcprolist = &nngcpro3 ))
+
+#define NNGCPRO4(var1, var2, var3, var4) ((void) ( \
+ nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \
+ nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \
+ nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \
+ nngcpro4.next = &nngcpro3, nngcpro4.var = &var4, nngcpro4.nvars = 1, \
+ gcprolist = &nngcpro4 ))
+
+#define NNGCPRO5(var1, var2, var3, var4, var5) \
+ ((void) ( \
+ nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \
+ nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \
+ nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \
+ nngcpro4.next = &nngcpro3, nngcpro4.var = &var4, nngcpro4.nvars = 1, \
+ nngcpro5.next = &nngcpro4, nngcpro5.var = &var5, nngcpro5.nvars = 1, \
+ gcprolist = &nngcpro5 ))
+
+#define NNUNGCPRO ((void) (gcprolist = nngcpro1.next))
#endif /* ! DEBUG_GCPRO */
/* "end-of-loop code not reached" */
/* "statement not reached */
#ifdef __SUNPRO_C
-#define RETURN__ if (1) return
+#define RETURN_SANS_WARNINGS if (1) return
#define RETURN_NOT_REACHED(value)
#else
-#define RETURN__ return
+#define RETURN_SANS_WARNINGS return
#define RETURN_NOT_REACHED(value) return value;
#endif
{ \
Lisp_Object ret_ungc_val = (expr); \
UNGCPRO; \
- RETURN__ ret_ungc_val; \
+ RETURN_SANS_WARNINGS ret_ungc_val; \
} while (0)
/* Evaluate expr, NUNGCPRO, UNGCPRO, and then return the value of expr. */
Lisp_Object ret_ungc_val = (expr); \
NUNGCPRO; \
UNGCPRO; \
- RETURN__ ret_ungc_val; \
+ RETURN_SANS_WARNINGS ret_ungc_val; \
} while (0)
/* Evaluate expr, NNUNGCPRO, NUNGCPRO, UNGCPRO, and then return the
NNUNGCPRO; \
NUNGCPRO; \
UNGCPRO; \
- RETURN__ ret_ungc_val; \
+ RETURN_SANS_WARNINGS ret_ungc_val; \
} while (0)
/* Evaluate expr, return it if it's not Qunbound. */
{ \
Lisp_Object ret_nunb_val = (expr); \
if (!UNBOUNDP (ret_nunb_val)) \
- RETURN__ ret_nunb_val; \
+ RETURN_SANS_WARNINGS ret_nunb_val; \
} while (0)
/* Call staticpro (&var) to protect static variable `var'. */
#define DIRECTORY_SEP '/'
#endif
#ifndef IS_DIRECTORY_SEP
-#define IS_DIRECTORY_SEP(_c_) ((_c_) == DIRECTORY_SEP)
+#define IS_DIRECTORY_SEP(c) ((c) == DIRECTORY_SEP)
#endif
#ifndef IS_DEVICE_SEP
#ifndef DEVICE_SEP
-#define IS_DEVICE_SEP(_c_) 0
+#define IS_DEVICE_SEP(c) 0
#else
-#define IS_DEVICE_SEP(_c_) ((_c_) == DEVICE_SEP)
+#define IS_DEVICE_SEP(c) ((c) == DEVICE_SEP)
#endif
#endif
#ifndef IS_ANY_SEP
-#define IS_ANY_SEP(_c_) (IS_DIRECTORY_SEP (_c_))
+#define IS_ANY_SEP(c) (IS_DIRECTORY_SEP (c))
#endif
#ifdef HAVE_INTTYPES_H
Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
Lisp_Object pure_list (int, Lisp_Object *);
Lisp_Object make_pure_vector (size_t, Lisp_Object);
-void free_cons (struct Lisp_Cons *);
+void free_cons (Lisp_Cons *);
void free_list (Lisp_Object);
void free_alist (Lisp_Object);
void mark_conses_in_list (Lisp_Object);
-void free_marker (struct Lisp_Marker *);
+void free_marker (Lisp_Marker *);
int object_dead_p (Lisp_Object);
#ifdef MEMORY_USAGE_STATS
Lisp_Object save_current_buffer_restore (Lisp_Object);
/* Defined in emacs.c */
-DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (fatal (CONST char *,
+DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (fatal (CONST char *,
...), 1, 2);
int stderr_out (CONST char *, ...) PRINTF_ARGS (1, 2);
int stdout_out (CONST char *, ...) PRINTF_ARGS (1, 2);
void maybe_signal_error (Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior);
Lisp_Object maybe_signal_continuable_error (Lisp_Object, Lisp_Object,
Lisp_Object, Error_behavior);
-DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (error (CONST char *,
+DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (error (CONST char *,
...), 1, 2);
void maybe_error (Lisp_Object, Error_behavior, CONST char *,
...) PRINTF_ARGS (3, 4);
Lisp_Object signal_simple_continuable_error (CONST char *, Lisp_Object);
Lisp_Object maybe_signal_simple_continuable_error (CONST char *, Lisp_Object,
Lisp_Object, Error_behavior);
-DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (error_with_frob
+DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (error_with_frob
(Lisp_Object, CONST char *,
...), 2, 3);
void maybe_error_with_frob (Lisp_Object, Lisp_Object, Error_behavior,
Lisp_Object maybe_signal_simple_continuable_error_2 (CONST char *, Lisp_Object,
Lisp_Object, Lisp_Object,
Error_behavior);
-Lisp_Object funcall_recording_as (Lisp_Object, int, Lisp_Object *);
+void signal_malformed_list_error (Lisp_Object);
+void signal_malformed_property_list_error (Lisp_Object);
+void signal_circular_list_error (Lisp_Object);
+void signal_circular_property_list_error (Lisp_Object);
+void signal_void_function_error (Lisp_Object);
Lisp_Object run_hook_with_args_in_buffer (struct buffer *, int, Lisp_Object *,
enum run_hooks_condition);
Lisp_Object run_hook_with_args (int, Lisp_Object *, enum run_hooks_condition);
/* Defined in events.c */
void clear_event_resource (void);
Lisp_Object allocate_event (void);
-int event_to_character (struct Lisp_Event *, int, int, int);
+int event_to_character (Lisp_Event *, int, int, int);
/* Defined in fileio.c */
void record_auto_save (void);
Lisp_Object vconcat2 (Lisp_Object, Lisp_Object);
Lisp_Object vconcat3 (Lisp_Object, Lisp_Object, Lisp_Object);
Lisp_Object nconc2 (Lisp_Object, Lisp_Object);
+Lisp_Object bytecode_nconc2 (Lisp_Object *);
void check_losing_bytecode (CONST char *, Lisp_Object);
/* Defined in getloadavg.c */
enum external_data_format);
void debug_print (Lisp_Object);
void debug_short_backtrace (int);
-void temp_output_buffer_setup (CONST char *);
+void temp_output_buffer_setup (Lisp_Object);
void temp_output_buffer_show (Lisp_Object, Lisp_Object);
/* NOTE: Do not call this with the data of a Lisp_String. Use princ.
* Note: stream should be defaulted before calling
void print_internal (Lisp_Object, Lisp_Object, int);
void print_symbol (Lisp_Object, Lisp_Object, int);
void print_float (Lisp_Object, Lisp_Object, int);
-void print_compiled_function (Lisp_Object, Lisp_Object, int);
extern int print_escape_newlines;
extern int print_readably;
-Lisp_Object internal_with_output_to_temp_buffer (CONST char *,
+Lisp_Object internal_with_output_to_temp_buffer (Lisp_Object,
Lisp_Object (*) (Lisp_Object),
Lisp_Object, Lisp_Object);
void float_to_string (char *, double);
Lisp_Object find_symbol_value (Lisp_Object);
Lisp_Object find_symbol_value_quickly (Lisp_Object, int);
Lisp_Object top_level_value (Lisp_Object);
+void reject_constant_symbols (Lisp_Object sym, Lisp_Object newval,
+ int function_p,
+ Lisp_Object follow_past_lisp_magic);
/* Defined in syntax.c */
int scan_words (struct buffer *, int, int);
EXFUN (Fchar_to_string, 1);
EXFUN (Fcheck_valid_plist, 1);
EXFUN (Fclear_range_table, 1);
-EXFUN (Fclrhash, 1);
EXFUN (Fcoding_category_list, 0);
EXFUN (Fcoding_category_system, 1);
EXFUN (Fcoding_priority_list, 0);
EXFUN (Fcoding_system_type, 1);
EXFUN (Fcommand_execute, 3);
EXFUN (Fcommandp, 1);
-EXFUN (Fcompiled_function_domain, 1);
EXFUN (Fconcat, MANY);
EXFUN (Fcons, 2);
EXFUN (Fcopy_alist, 1);
EXFUN (Fcopy_coding_system, 2);
EXFUN (Fcopy_event, 2);
+EXFUN (Fcopy_list, 1);
EXFUN (Fcopy_marker, 2);
EXFUN (Fcopy_sequence, 1);
EXFUN (Fcopy_tree, 2);
EXFUN (Fget_coding_system, 1);
EXFUN (Fget_process, 1);
EXFUN (Fget_range_table, 3);
-EXFUN (Fgethash, 3);
EXFUN (Fgettext, 1);
EXFUN (Fgoto_char, 2);
EXFUN (Fgtr, MANY);
-EXFUN (Fhashtablep, 1);
EXFUN (Findent_to, 3);
EXFUN (Findirect_function, 1);
EXFUN (Finsert, MANY);
EXFUN (Fmake_byte_code, MANY);
EXFUN (Fmake_coding_system, 4);
EXFUN (Fmake_glyph_internal, 1);
-EXFUN (Fmake_hashtable, 2);
EXFUN (Fmake_list, 2);
EXFUN (Fmake_marker, 0);
EXFUN (Fmake_range_table, 0);
EXFUN (Fput, 3);
EXFUN (Fput_range_table, 4);
EXFUN (Fput_text_property, 5);
-EXFUN (Fputhash, 3);
EXFUN (Fquo, MANY);
EXFUN (Frassq, 2);
EXFUN (Fread, 1);
extern Lisp_Object Qcategory_designator_p, Qcategory_table_value_p, Qccl, Qcdr;
extern Lisp_Object Qchannel, Qchar, Qchar_or_string_p, Qcharacter, Qcharacterp;
extern Lisp_Object Qchars, Qcharset_g0, Qcharset_g1, Qcharset_g2, Qcharset_g3;
-extern Lisp_Object Qcircular_property_list, Qcoding_system_error;
-extern Lisp_Object Qcoding_system_p, Qcolor, Qcolor_pixmap_image_instance_p;
+extern Lisp_Object Qcircular_list, Qcircular_property_list;
+extern Lisp_Object Qcoding_system_error, Qcoding_system_p;
+extern Lisp_Object Qcolor, Qcolor_pixmap_image_instance_p;
extern Lisp_Object Qcolumns, Qcommand, Qcommandp, Qcompletion_ignore_case;
extern Lisp_Object Qconsole, Qconsole_live_p, Qconst_specifier, Qcr, Qcritical;
extern Lisp_Object Qcrlf, Qctext, Qcurrent_menubar, Qcursor;
extern Lisp_Object Qinvalid_function, Qinvalid_read_syntax, Qio_error;
extern Lisp_Object Qiso2022, Qkey, Qkey_assoc, Qkeymap, Qlambda, Qleft, Qlf;
extern Lisp_Object Qlist, Qlistp, Qload, Qlock_shift, Qmacro, Qmagic;
-extern Lisp_Object Qmalformed_property_list, Qmalloc_overhead, Qmark, Qmarkers;
+extern Lisp_Object Qmalformed_list, Qmalformed_property_list;
+extern Lisp_Object Qmalloc_overhead, Qmark, Qmarkers;
extern Lisp_Object Qmax, Qmemory, Qmessage, Qminus, Qmnemonic, Qmodifiers;
extern Lisp_Object Qmono_pixmap_image_instance_p, Qmotion;
extern Lisp_Object Qmouse_leave_buffer_hook, Qmswindows, Qname, Qnas, Qnatnump;
-extern Lisp_Object Qnil, Qno_ascii_cntl, Qno_ascii_eol, Qno_catch;
+extern Lisp_Object Qno_ascii_cntl, Qno_ascii_eol, Qno_catch;
extern Lisp_Object Qno_conversion, Qno_iso6429, Qnone, Qnot, Qnothing;
extern Lisp_Object Qnothing_image_instance_p, Qnotice;
extern Lisp_Object Qnumber_char_or_marker_p, Qnumber_or_marker_p, Qnumberp;
extern Lisp_Object Vbinary_process_output, Vblank_menubar;
extern Lisp_Object Vcharset_ascii, Vcharset_composite, Vcharset_control_1;
extern Lisp_Object Vcoding_system_for_read, Vcoding_system_for_write;
-extern Lisp_Object Vcoding_system_hashtable, Vcommand_history;
+extern Lisp_Object Vcoding_system_hash_table, Vcommand_history;
extern Lisp_Object Vcommand_line_args, Vconfigure_info_directory;
extern Lisp_Object Vconsole_list, Vcontrolling_terminal;
extern Lisp_Object Vcurrent_compiled_function_annotation, Vcurrent_load_list;
extern Lisp_Object Vwin32_generate_fake_inodes, Vwin32_pipe_read_delay;
extern Lisp_Object Vx_initial_argv_list;
+extern Lisp_Object Qmakunbound, Qset;
#endif /* _XEMACS_LISP_H_ */
#include "buffer.h"
#include "bytecode.h"
-#include "commands.h"
-#include "insdel.h"
+#include "elhash.h"
#include "lstream.h"
#include "opaque.h"
-#include <paths.h>
#ifdef FILE_CODING
#include "file-coding.h"
#endif
something to `funcall', but who would really do that? As
they say in law, we've made a "good-faith effort" to
unfuckify ourselves. And doing it this way avoids screwing
- up args to `make-hashtable' and such. As it is, we have to
+ up args to `make-hash-table' and such. As it is, we have to
add an extra Ebola check in decode_weak_list_type(). --ben */
- if (EQ (el, Qassoc))
- el = Qold_assoc;
- if (EQ (el, Qdelq))
- el = Qold_delq;
+ if (EQ (el, Qassoc)) el = Qold_assoc;
+ else if (EQ (el, Qdelq)) el = Qold_delq;
#if 0
/* I think this is a bad idea because it will probably mess
with keymap code. */
- if (EQ (el, Qdelete))
- el = Qold_delete;
+ else if (EQ (el, Qdelete)) el = Qold_delete;
#endif
- if (EQ (el, Qrassq))
- el = Qold_rassq;
- if (EQ (el, Qrassoc))
- el = Qold_rassoc;
+ else if (EQ (el, Qrassq)) el = Qold_rassq;
+ else if (EQ (el, Qrassoc)) el = Qold_rassoc;
+
XVECTOR_DATA (vector)[i] = el;
}
}
Lisp_Object doc;
assert (COMPILED_FUNCTIONP (john));
- if (CONSP (XCOMPILED_FUNCTION (john)->bytecodes))
+ if (CONSP (XCOMPILED_FUNCTION (john)->instructions))
{
struct gcpro ngcpro1;
Lisp_Object juan = (pas_de_lache_ici
- (fd, XCOMPILED_FUNCTION (john)->bytecodes));
+ (fd, XCOMPILED_FUNCTION (john)->instructions));
Lisp_Object ivan;
NGCPRO1 (juan);
if (!CONSP (ivan))
signal_simple_error ("invalid lazy-loaded byte code", ivan);
/* Remember to purecopy; see above. */
- XCOMPILED_FUNCTION (john)->bytecodes = Fpurecopy (XCAR (ivan));
+ XCOMPILED_FUNCTION (john)->instructions = Fpurecopy (XCAR (ivan));
/* v18 or v19 bytecode file. Need to Ebolify. */
if (XCOMPILED_FUNCTION (john)->flags.ebolified
&& VECTORP (XCDR (ivan)))
if (purify_flag && noninteractive)
{
if (EQ (last_file_loaded, file))
- message_append (" (%ld)",
+ message_append (" (%ld)",
(unsigned long) (purespace_usage() - pure_usage));
else
message ("Loading %s ...done (%ld)", XSTRING_DATA (file),
if (!NILP (mode))
CHECK_NATNUM (mode);
- locate_file (path_list, filename,
- ((NILP (suffixes)) ? "" :
- (char *) (XSTRING_DATA (suffixes))),
- &tp, (NILP (mode) ? R_OK : XINT (mode)));
+ locate_file (path_list,
+ filename,
+ NILP (suffixes) ? "" : (char *) XSTRING_DATA (suffixes),
+ &tp,
+ NILP (mode) ? R_OK : XINT (mode));
return tp;
}
static Lisp_Object
locate_file_refresh_hashing (Lisp_Object str)
{
- Lisp_Object hash =
- make_directory_hash_table ((char *) XSTRING_DATA (str));
+ Lisp_Object hash = make_directory_hash_table ((char *) XSTRING_DATA (str));
Fput (str, Qlocate_file_hash_table, hash);
return hash;
}
locate_file_find_directory_hash_table (Lisp_Object str)
{
Lisp_Object hash = Fget (str, Qlocate_file_hash_table, Qnil);
- if (NILP (Fhashtablep (hash)))
+ if (! HASH_TABLEP (hash))
return locate_file_refresh_hashing (str);
return hash;
}
default-directory to be something non-absolute ... */
{
if (NILP (filename))
- /* NIL means current dirctory */
+ /* NIL means current directory */
filename = current_buffer->directory;
else
filename = Fexpand_file_name (filename,
for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail))
{
Lisp_Object pathel = Fcar (pathtail);
- Lisp_Object hashtab;
+ Lisp_Object hash_table;
Lisp_Object tail;
int found;
continue;
}
- hashtab = locate_file_find_directory_hash_table (pathel);
+ hash_table = locate_file_find_directory_hash_table (pathel);
/* Loop over suffixes. */
for (tail = suffixtab, found = 0; !found && CONSP (tail);
tail = XCDR (tail))
{
- if (!NILP (Fgethash (XCAR (tail), hashtab, Qnil)))
+ if (!NILP (Fgethash (XCAR (tail), hash_table, Qnil)))
found = 1;
}
{
/* This function can GC */
REGISTER Emchar c;
- REGISTER Lisp_Object val;
+ REGISTER Lisp_Object val = Qnil;
int speccount = specpdl_depth ();
- struct gcpro gcpro1;
+ struct gcpro gcpro1, gcpro2;
struct buffer *b = 0;
if (BUFFERP (readcharfun))
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
Vcurrent_compiled_function_annotation = Qnil;
#endif
- GCPRO1 (sourcename);
+ GCPRO2 (val, sourcename);
LOADHIST_ATTACH (sourcename);
obj = read0(readcharfun);
/* the call to `featurep' may GC. */
- GCPRO2(fexp, obj);
- tem = call1(Qfeaturep, fexp);
+ GCPRO2 (fexp, obj);
+ tem = call1 (Qfeaturep, fexp);
UNGCPRO;
- if (c == '+' && NILP(tem)) goto retry;
+ if (c == '+' && NILP(tem)) goto retry;
if (c == '-' && !NILP(tem)) goto retry;
return obj;
}
Vvalues = Qnil;
load_in_progress = 0;
-
+
Vload_descriptor_list = Qnil;
/* kludge: locate-file does not work for a null load-path, even if
a `next' pointer, and are allocated using alloc_lcrecord().
Creating a new lcrecord type is fairly easy; just follow the
- lead of some existing type (e.g. hashtables). Note that you
+ lead of some existing type (e.g. hash tables). Note that you
do not need to supply all the methods (see below); reasonable
defaults are provided for many of them. Alternatively, if you're
just looking for a way of encapsulating data (which possibly
*/
#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
/* index into lrecord_implementations_table[] */
- unsigned type:8;
+ unsigned char type;
/* 1 if the object is marked during GC, 0 otherwise. */
- unsigned mark:1;
+ char mark;
/* 1 if the object resides in pure (read-only) space */
- unsigned pure:1;
+ char pure;
#else
CONST struct lrecord_implementation *implementation;
#endif
int lrecord_type_index (CONST struct lrecord_implementation *implementation);
#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
-# define set_lheader_implementation(header,imp) do \
-{ \
- (header)->type = lrecord_type_index (imp); \
- (header)->mark = 0; \
- (header)->pure = 0; \
+# define set_lheader_implementation(header,imp) do { \
+ struct lrecord_header* SLI_header = (header); \
+ (SLI_header)->type = lrecord_type_index (imp); \
+ (SLI_header)->mark = 0; \
+ (SLI_header)->pure = 0; \
} while (0)
#else
# define set_lheader_implementation(header,imp) \
struct lcrecord_header
{
struct lrecord_header lheader;
- /* The "next" field is normally used to chain all lrecords together
+
+ /* The `next' field is normally used to chain all lrecords together
so that the GC can find (and free) all of them.
- "alloc_lcrecord" threads records together.
+ `alloc_lcrecord' threads records together.
+
+ The `next' field may be used for other purposes as long as some
+ other mechanism is provided for letting the GC do its work.
- The "next" field may be used for other purposes as long as some
- other mechanism is provided for letting the GC do its work. (For
- example, the event and marker datatypes allocate members out of
- memory chunks, and are able to find all unmarked members by
- sweeping through the elements of the list of chunks) */
+ For example, the event and marker object types allocate members
+ out of memory chunks, and are able to find all unmarked members
+ by sweeping through the elements of the list of chunks. */
struct lcrecord_header *next;
- /* This is just for debugging/printing convenience.
- Having this slot doesn't hurt us much spacewise, since an lcrecord
- already has the above slots together with malloc overhead. */
+
+ /* The `uid' field is just for debugging/printing convenience.
+ Having this slot doesn't hurt us much spacewise, since an
+ lcrecord already has the above slots plus malloc overhead. */
unsigned int uid :31;
- /* A flag that indicates whether this lcrecord is on a "free list".
- Free lists are used to minimize the number of calls to malloc()
- when we're repeatedly allocating and freeing a number of the
- same sort of lcrecord. Lcrecords on a free list always get
- marked in a different fashion, so we can use this flag as a
- sanity check to make sure that free lists only have freed lcrecords
- and there are no freed lcrecords elsewhere. */
+
+ /* The `free' field is a flag that indicates whether this lcrecord
+ is on a "free list". Free lists are used to minimize the number
+ of calls to malloc() when we're repeatedly allocating and freeing
+ a number of the same sort of lcrecord. Lcrecords on a free list
+ always get marked in a different fashion, so we can use this flag
+ as a sanity check to make sure that free lists only have freed
+ lcrecords and there are no freed lcrecords elsewhere. */
unsigned int free :1;
};
};
/* This as the value of lheader->implementation->finalizer
- * means that this record is already marked */
+ means that this record is already marked */
void this_marks_a_marked_record (void *, int);
/* see alloc.c for an explanation */
#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
-# define MARKED_RECORD_HEADER_P(lheader) (lheader)->mark
-# define MARK_RECORD_HEADER(lheader) (lheader)->mark = 1
-# define UNMARK_RECORD_HEADER(lheader) (lheader)->mark = 0
+# define MARKED_RECORD_HEADER_P(lheader) ((lheader)->mark)
+# define MARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 1))
+# define UNMARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 0))
#else /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */
# define MARKED_RECORD_HEADER_P(lheader) \
- (((lheader)->implementation->finalizer) == this_marks_a_marked_record)
-# define MARK_RECORD_HEADER(lheader) \
- do { (((lheader)->implementation)++); } while (0)
-# define UNMARK_RECORD_HEADER(lheader) \
- do { (((lheader)->implementation)--); } while (0)
+ ((lheader)->implementation->finalizer == this_marks_a_marked_record)
+# define MARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)++))
+# define UNMARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)--))
#endif /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */
#define UNMARKABLE_RECORD_HEADER_P(lheader) \
- ((LHEADER_IMPLEMENTATION (lheader)->marker) \
- == this_one_is_unmarkable)
+ (LHEADER_IMPLEMENTATION (lheader)->marker == this_one_is_unmarkable)
/* Declaring the following structures as const puts them in the
text (read-only) segment, which makes debugging inconvenient
# define DECLARE_LRECORD(c_name, structtype) \
extern CONST_IF_NOT_DEBUG struct lrecord_implementation \
lrecord_##c_name[]; \
-INLINE structtype *error_check_##c_name (Lisp_Object _obj); \
+INLINE structtype *error_check_##c_name (Lisp_Object obj); \
INLINE structtype * \
-error_check_##c_name (Lisp_Object _obj) \
+error_check_##c_name (Lisp_Object obj) \
{ \
- XUNMARK (_obj); \
- assert (RECORD_TYPEP (_obj, lrecord_##c_name) || \
- MARKED_RECORD_P (_obj)); \
- return (structtype *) XPNTR (_obj); \
+ XUNMARK (obj); \
+ assert (RECORD_TYPEP (obj, lrecord_##c_name) || \
+ MARKED_RECORD_P (obj)); \
+ return (structtype *) XPNTR (obj); \
} \
extern Lisp_Object Q##c_name##p
# define DECLARE_NONRECORD(c_name, type_enum, structtype) \
-INLINE structtype *error_check_##c_name (Lisp_Object _obj); \
+INLINE structtype *error_check_##c_name (Lisp_Object obj); \
INLINE structtype * \
-error_check_##c_name (Lisp_Object _obj) \
+error_check_##c_name (Lisp_Object obj) \
{ \
- XUNMARK (_obj); \
- assert (XGCTYPE (_obj) == type_enum); \
- return (structtype *) XPNTR (_obj); \
+ XUNMARK (obj); \
+ assert (XGCTYPE (obj) == type_enum); \
+ return (structtype *) XPNTR (obj); \
} \
extern Lisp_Object Q##c_name##p
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? */
char servername[256];
CHECK_STRING (server);
- strncpy (servername, XSTRING (server)->_data, XSTRING (server)->_size);
- servername[XSTRING (server)->_size] = '\0';
+ strncpy (servername, XSTRING_DATA (server), XSTRING_LENGTH (server));
+ servername[XSTRING_LENGTH (server)] = '\0';
jrKanjiControl (0, KC_SETSERVERNAME, servername);
}
char rcname[256];
CHECK_STRING (rcfile);
- strncpy (rcname, XSTRING (rcfile)->_data, XSTRING (rcfile)->_size);
- rcname[XSTRING (rcfile)->_size] = '\0';
+ strncpy (rcname, XSTRING_DATA (rcfile), XSTRING_LENGTH (rcfile));
+ rcname[XSTRING_LENGTH (rcfile)] = '\0';
jrKanjiControl (0, KC_SETINITFILENAME, rcname);
}
if (res == -1)
{
- val = Fcons (make_string ((unsigned char*) jrKanjiError,
+ val = Fcons (make_string ((unsigned char*) jrKanjiError,
strlen (jrKanjiError)), val);
/* ¥¤¥Ë¥·¥ã¥é¥¤¥º¤Ç¼ºÇÔ¤·¤¿¾ì¹ç¡£ */
return Fcons (Qnil, val);
ksv.buffer = (unsigned char *) buf;
ksv.bytes_buffer = KEYTOSTRSIZE;
#ifndef CANNA_MULE
- ks.echoStr = XSTRING (str)->_data;
- ks.length = XSTRING (str)->_size;
+ ks.echoStr = XSTRING_DATA (str);
+ ks.length = XSTRING_LENGTH (str);
#else /* CANNA_MULE */
- m2c (XSTRING (str)->_data, XSTRING (str)->_size, cbuf);
+ m2c (XSTRING_DATA (str), XSTRING_LENGTH (str), cbuf);
ks.echoStr = cbuf;
ks.length = strlen (cbuf);
#endif /* CANNA_MULE */
}
DEFUN ("canna-set-width", Fcanna_set_width, 1, 1, 0, /*
-Set status-line width information, which is used to display
+Set status-line width information, which is used to display
kanji candidates.
*/
(num))
CHECK_STRING (yomi);
#ifndef CANNA_MULE
- strncpy (buf, XSTRING (yomi)->_data, XSTRING (yomi)->_size);
- ks.length = XSTRING (yomi)->_size;
+ strncpy (buf, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi));
+ ks.length = XSTRING_LENGTH (yomi);
buf[ks.length] = '\0';
#else /* CANNA_MULE */
- m2c (XSTRING (yomi)->_data, XSTRING (yomi)->_size, buf);
+ m2c (XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), buf);
ks.length = strlen (buf);
#endif /* CANNA_MULE */
CHECK_STRING (roma);
#ifndef CANNA_MULE
- strncpy (buf + XSTRING (yomi)->_size + 1, XSTRING (roma)->_data,
- XSTRING (roma)->_size);
- buf[XSTRING (yomi)->_size + 1 + XSTRING (roma)->_size] = '\0';
- ks.mode = (unsigned char *)(buf + XSTRING (yomi)->_size + 1);
+ strncpy (buf + XSTRING_LENGTH (yomi) + 1, XSTRING_DATA (roma),
+ XSTRING_LENGTH (roma));
+ buf[XSTRING_LENGTH (yomi) + 1 + XSTRING_LENGTH (roma)] = '\0';
+ ks.mode = (unsigned char *)(buf + XSTRING_LENGTH (yomi) + 1);
#else /* CANNA_MULE */
ks.mode = (unsigned char *)(buf + ks.length + 1);
- m2c (XSTRING (roma)->_data, XSTRING (roma)->_size, ks.mode);
+ m2c (XSTRING_DATA (roma), XSTRING_LENGTH (roma), ks.mode);
#endif /* CANNA_MULE */
}
CHECK_STRING (str);
#ifndef CANNA_MULE
- strncpy (buf, XSTRING (str)->_data, XSTRING (str)->_size);
- buf[XSTRING (str)->_size] = '\0';
+ strncpy (buf, XSTRING_DATA (str), XSTRING_LENGTH (str));
+ buf[XSTRING_LENGTH (str)] = '\0';
#else /* CANNA_MULE */
- m2c (XSTRING (str)->_data, XSTRING (str)->_size, buf);
+ m2c (XSTRING_DATA (str), XSTRING_LENGTH (str), buf);
#endif /* CANNA_MULE */
p = (unsigned char**) buf;
n = jrKanjiControl (0, KC_PARSE, (char *) &p);
return Qnil;
}
#ifndef CANNA_MULE
- strncpy (yomibuf, XSTRING (yomi)->_data, XSTRING (yomi)->_size);
- yomibuf[XSTRING (yomi)->_size] = '\0';
- nbun = RkBgnBun (IRCP_context, XSTRING (yomi)->_data, XSTRING (yomi)->_size,
+ strncpy (yomibuf, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi));
+ yomibuf[XSTRING_LENGTH (yomi)] = '\0';
+ nbun = RkBgnBun (IRCP_context, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi),
(RK_XFER << RK_XFERBITS) | RK_KFER);
#else /* CANNA_MULE */
- m2c (XSTRING (yomi)->_data, XSTRING (yomi)->_size, yomibuf);
+ m2c (XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), yomibuf);
nbun = RkBgnBun (IRCP_context, (char *) yomibuf, strlen (yomibuf),
(RK_XFER << RK_XFERBITS) | RK_KFER);
#endif /* CANNA_MULE */
CHECK_INT (bunsetsu);
CHECK_INT (bunlen);
-
+
nbun = XINT (bunsetsu);
if (confirmContext () == 0)
{
{
DEFVAR_LISP ("CANNA", &VCANNA); /* hir@nec, 1992.5.21 */
VCANNA = Qt; /* hir@nec, 1992.5.21 */
-
+
DEFSUBR (Fcanna_key_proc);
DEFSUBR (Fcanna_initialize);
DEFSUBR (Fcanna_finalize);
c2mu (char *cp, int l, char *mp)
{
char ch, *ep = cp+l;
-
+
while ((cp < ep) && (ch = *cp))
{
if ((unsigned char) ch == ISO_CODE_SS2)
static void
m2c (unsigned char *mp, int l, unsigned char *cp)
{
- unsigned char ch, *ep = mp + l;;
-
+ unsigned char ch, *ep = mp + l;
+
while ((mp < ep) && (ch = *mp++))
{
switch (ch)
*cp++ = ch;
break;
}
- }
+ }
*cp = 0;
}
mule_make_string (unsigned char *p, int l)
{
unsigned char cbuf[4096];
-
+
c2mu (p,l,cbuf);
return (make_string (cbuf,strlen (cbuf)));
-}
+}
/* return the MULE internal string length of EUC string */
/* Modified by sb to return a character count not byte count. */
{
unsigned char ch, *cp = p;
int len = 0;
-
+
while ((cp < p + l) && (ch = *cp))
{
if ((unsigned char) ch == ISO_CODE_SS2)
else
{
len++;
- cp++;
+ cp++;
}
}
return (len);
int *crev)
{
unsigned char *q = p;
-
+
*clen = *cpos = *crev = 0;
if (len == 0) return;
while (q < p + pos)
(*clen)++;
(*crev)++;
if (*q++ & 0x80) q++;
- }
+ }
while (q < p + len)
{
(*clen)++;
case CCL_MOD: reg[rrr] = i % j; break;
case CCL_AND: reg[rrr] = i & j; break;
case CCL_OR: reg[rrr] = i | j; break;
- case CCL_XOR: reg[rrr] = i ^ j;; break;
+ case CCL_XOR: reg[rrr] = i ^ j; break;
case CCL_LSH: reg[rrr] = i << j; break;
case CCL_RSH: reg[rrr] = i >> j; break;
case CCL_LSH8: reg[rrr] = (i << 8) | j; break;
Lisp_Object Vcharset_korean_ksc5601;
Lisp_Object Vcharset_composite;
-/* Hashtables for composite chars. One maps string representing
+/* Hash tables for composite chars. One maps string representing
composed chars to their equivalent chars; one goes the
other way. */
-Lisp_Object Vcomposite_char_char2string_hashtable;
-Lisp_Object Vcomposite_char_string2char_hashtable;
+Lisp_Object Vcomposite_char_char2string_hash_table;
+Lisp_Object Vcomposite_char_string2char_hash_table;
/* Table of charsets indexed by leading byte. */
Lisp_Object charset_by_leading_byte[128];
Lisp_Object Ql2r, Qr2l;
-Lisp_Object Vcharset_hashtable;
+Lisp_Object Vcharset_hash_table;
static Bufbyte next_allocated_1_byte_leading_byte;
static Bufbyte next_allocated_2_byte_leading_byte;
if (f1 + FIELD1_TO_OFFICIAL_LEADING_BYTE == LEADING_BYTE_COMPOSITE)
{
if (UNBOUNDP (Fgethash (make_int (ch),
- Vcomposite_char_char2string_hashtable,
+ Vcomposite_char_char2string_hash_table,
Qunbound)))
return 0;
return 1;
{
struct Lisp_Charset *cs = XCHARSET (obj);
- (markobj) (cs->doc_string);
- (markobj) (cs->registry);
- (markobj) (cs->ccl_program);
+ markobj (cs->doc_string);
+ markobj (cs->registry);
+ markobj (cs->ccl_program);
return cs->name;
}
CHARSET_TYPE (cs) == CHARSET_TYPE_96) ? 1 : 2;
CHARSET_CHARS (cs) = (CHARSET_TYPE (cs) == CHARSET_TYPE_94 ||
CHARSET_TYPE (cs) == CHARSET_TYPE_94X94) ? 94 : 96;
-
+
if (final)
{
/* some charsets do not have final characters. This includes
/* Some charsets are "faux" and don't have names or really exist at
all except in the leading-byte table. */
if (!NILP (name))
- Fputhash (name, obj, Vcharset_hashtable);
+ Fputhash (name, obj, Vcharset_hash_table);
return obj;
}
return charset_or_name;
CHECK_SYMBOL (charset_or_name);
- return Fgethash (charset_or_name, Vcharset_hashtable, Qnil);
+ return Fgethash (charset_or_name, Vcharset_hash_table, Qnil);
}
DEFUN ("get-charset", Fget_charset, 1, 1, 0, /*
};
static int
-add_charset_to_list_mapper (CONST void *hash_key, void *hash_contents,
+add_charset_to_list_mapper (Lisp_Object key, Lisp_Object value,
void *charset_list_closure)
{
/* This function can GC */
- Lisp_Object key, contents;
- Lisp_Object *charset_list;
struct charset_list_closure *chcl =
(struct charset_list_closure*) charset_list_closure;
- CVOID_TO_LISP (key, hash_key);
- VOID_TO_LISP (contents, hash_contents);
- charset_list = chcl->charset_list;
+ Lisp_Object *charset_list = chcl->charset_list;
- *charset_list = Fcons (XCHARSET_NAME (contents), *charset_list);
+ *charset_list = Fcons (XCHARSET_NAME (value), *charset_list);
return 0;
}
GCPRO1 (charset_list);
charset_list_closure.charset_list = &charset_list;
- elisp_maphash (add_charset_to_list_mapper, Vcharset_hashtable,
+ elisp_maphash (add_charset_to_list_mapper, Vcharset_hash_table,
&charset_list_closure);
UNGCPRO;
invalidate_charset_font_caches (Lisp_Object charset)
{
/* Invalidate font cache entries for charset on all devices. */
- Lisp_Object devcons, concons, hashtab;
+ Lisp_Object devcons, concons, hash_table;
DEVICE_LOOP_NO_BREAK (devcons, concons)
{
struct device *d = XDEVICE (XCAR (devcons));
- hashtab = Fgethash (charset, d->charset_font_cache, Qunbound);
- if (!UNBOUNDP (hashtab))
- Fclrhash (hashtab);
+ hash_table = Fgethash (charset, d->charset_font_cache, Qunbound);
+ if (!UNBOUNDP (hash_table))
+ Fclrhash (hash_table);
}
}
{
Lisp_Object lispstr = make_string (str, len);
Lisp_Object ch = Fgethash (lispstr,
- Vcomposite_char_string2char_hashtable,
+ Vcomposite_char_string2char_hash_table,
Qunbound);
Emchar emch;
emch = MAKE_CHAR (Vcharset_composite, composite_char_row_next,
composite_char_col_next);
Fputhash (make_char (emch), lispstr,
- Vcomposite_char_char2string_hashtable);
+ Vcomposite_char_char2string_hash_table);
Fputhash (lispstr, make_char (emch),
- Vcomposite_char_string2char_hashtable);
+ Vcomposite_char_string2char_hash_table);
composite_char_col_next++;
if (composite_char_col_next >= 128)
{
composite_char_string (Emchar ch)
{
Lisp_Object str = Fgethash (make_char (ch),
- Vcomposite_char_char2string_hashtable,
+ Vcomposite_char_char2string_hash_table,
Qunbound);
assert (!UNBOUNDP (str));
return str;
void
complex_vars_of_mule_charset (void)
{
- staticpro (&Vcharset_hashtable);
- Vcharset_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK,
- HASHTABLE_EQ);
+ staticpro (&Vcharset_hash_table);
+ Vcharset_hash_table =
+ make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
/* Predefined character sets. We store them into variables for
ease of access. */
composite_char_row_next = 32;
composite_char_col_next = 32;
- Vcomposite_char_string2char_hashtable =
- make_lisp_hashtable (500, HASHTABLE_NONWEAK, HASHTABLE_EQUAL);
- Vcomposite_char_char2string_hashtable =
- make_lisp_hashtable (500, HASHTABLE_NONWEAK, HASHTABLE_EQ);
- staticpro (&Vcomposite_char_string2char_hashtable);
- staticpro (&Vcomposite_char_char2string_hashtable);
+ Vcomposite_char_string2char_hash_table =
+ make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL);
+ Vcomposite_char_char2string_hash_table =
+ make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
+ staticpro (&Vcomposite_char_string2char_hash_table);
+ staticpro (&Vcomposite_char_char2string_hash_table);
}
#define WNNSERVER_T 2
#define WNNSERVER_K 3
-int check_wnn_server_type (void);
+int check_wnn_server_type (void);
void w2m (w_char *wp, unsigned char *mp, unsigned char lb);
void m2w (unsigned char *mp, w_char *wp);
void w2y (w_char *w);
case WNNSERVER_C:
langname = "zh_CN";
break;
-/*
+/*
case WNNSERVER_T:
strcpy (langname, "zh_TW");
break;
DEFUN ("wnn-server-close", Fwnn_close, 0, 0, 0, /*
-Close the connection to jserver, Dictionary and friquency files
+Close the connection to jserver, Dictionary and frequency files
are not saved.
*/
())
if (!wnnfns_buf[snum]) return Qnil;
if (wnnfns_env_norm[snum])
{
- if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_norm[snum]);
+ if (NILP (Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_norm[snum]);
else jl_env_sticky_e (wnnfns_env_norm[snum]);
jl_disconnect (wnnfns_env_norm[snum]);
}
if (wnnfns_env_rev[snum])
{
- if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_rev[snum]);
+ if (NILP (Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_rev[snum]);
else jl_env_sticky_e (wnnfns_env_rev[snum]);
jl_disconnect (wnnfns_env_rev[snum]);
}
CHECK_STRING (args[0]);
CHECK_STRING (args[1]);
CHECK_INT (args[2]);
- if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]);
- if (!EQ(args[6], Qnil)) CHECK_STRING (args[6]);
+ if (! NILP (args[5])) CHECK_STRING (args[5]);
+ if (! NILP (args[6])) CHECK_STRING (args[6]);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
GCPRO1 (*args);
gcpro1.nvars = nargs;
if (jl_dic_add (wnnfns_buf[snum],
- XSTRING (args[0])->_data,
- XSTRING (args[1])->_data,
+ XSTRING_DATA (args[0]),
+ XSTRING_DATA (args[1]),
wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV,
XINT (args[2]),
- (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW,
- (EQ(args[4], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW,
- (EQ(args[5], Qnil)) ? 0 : XSTRING (args[5])->_data,
- (EQ(args[6], Qnil)) ? 0 : XSTRING (args[6])->_data,
+ NILP (args[3]) ? WNN_DIC_RDONLY : WNN_DIC_RW,
+ NILP (args[4]) ? WNN_DIC_RDONLY : WNN_DIC_RW,
+ NILP (args[5]) ? 0 : XSTRING_DATA (args[5]),
+ NILP (args[6]) ? 0 : XSTRING_DATA (args[6]),
yes_or_no,
puts2 ) < 0)
{
int cnt, i;
unsigned char comment[1024];
Lisp_Object val;
- int snum;
+ int snum;
unsigned char lb;
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
DEFUN ("wnn-server-dict-comment", Fwnn_dict_comment, 2, 2, 0, /*
Set comment to dictionary specified by DIC-NUMBER.
Comment string COMMENT
-*/
+*/
(dicno, comment))
{
w_char wbuf[512];
CHECK_STRING (comment);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
- m2w (XSTRING (comment)->_data, wbuf);
- if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0)
+ m2w (XSTRING_DATA (comment), wbuf);
+ if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0)
return Qnil;
return Qt;
}
{
int snum;
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
- if (EQ(rev, Qnil))
+ if (NILP (rev))
{
if ((!wnnfns_buf[snum]) || (!wnnfns_env_norm[snum])) return Qnil;
jl_env_set (wnnfns_buf[snum], wnnfns_env_norm[snum]);
CHECK_STRING (hstring);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
- m2w (XSTRING (hstring)->_data, wbuf);
+ m2w (XSTRING_DATA (hstring), wbuf);
if (snum == WNNSERVER_C)
w2y (wbuf);
#ifdef WNN6
- if ((cnt = jl_fi_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0)
+ if ((cnt = jl_fi_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0)
return Qnil;
#else
- if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0)
+ if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0)
return Qnil;
#endif
return make_int (cnt);
CHECK_INT (offset);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
- if (EQ(dai, Qnil))
+ if (NILP (dai))
{
if (jl_set_jikouho (wnnfns_buf[snum], XINT (offset)) < 0) return Qnil;
}
no = XINT (bunNo);
#ifdef WNN6
if ((cnt = jl_fi_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE,
- (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0)
+ NILP (dai) ? WNN_SHO : WNN_DAI)) < 0)
return Qnil;
#else
if ((cnt = jl_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE,
- (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0)
+ NILP (dai) ? WNN_SHO : WNN_DAI)) < 0)
return Qnil;
#endif
return make_int (cnt);
int no;
int snum;
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
- if (EQ(bunNo, Qnil)) no = -1;
+ if (NILP (bunNo)) no = -1;
else
{
CHECK_INT (bunNo);
CHECK_INT (hinsi);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
- m2w (XSTRING (yomi)->_data, yomi_buf);
+ m2w (XSTRING_DATA (yomi), yomi_buf);
if (snum == WNNSERVER_C)
w2y (yomi_buf);
- m2w (XSTRING (kanji)->_data, kanji_buf);
- m2w (XSTRING (comment)->_data, comment_buf);
+ m2w (XSTRING_DATA (kanji), kanji_buf);
+ m2w (XSTRING_DATA (comment), comment_buf);
if (jl_word_add (wnnfns_buf[snum], XINT (dicno), yomi_buf, kanji_buf,
- comment_buf, XINT (hinsi), 0) < 0)
+ comment_buf, XINT (hinsi), 0) < 0)
return Qnil;
else return Qt;
}
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
lb = lb_wnn_server_type[snum];
if (!wnnfns_buf[snum]) return Qnil;
- m2w (XSTRING (yomi)->_data, wbuf);
+ m2w (XSTRING_DATA (yomi), wbuf);
if (snum == WNNSERVER_C)
w2y (wbuf);
if ((count = jl_word_search_by_env (wnnfns_buf[snum],
CHECK_INT (val);
setval = XINT (val);
if (EQ (key, Qwnn_n)) param.n = setval;
- else if (EQ (key, Qwnn_nsho)) param.nsho = setval;
+ else if (EQ (key, Qwnn_nsho)) param.nsho = setval;
else if (EQ (key, Qwnn_hindo)) param.p1 = setval;
else if (EQ (key, Qwnn_len)) param.p2 = setval;
else if (EQ (key, Qwnn_jiri)) param.p3 = setval;
#if 0
printf("wnn_n = %d\n",param.n);
printf("wnn_nsho = %d\n",param.nsho);
- printf("wnn_hindo = %d\n",param.p1);
- printf("wnn_len = %d\n",param.p2);
- printf("wnn_jiri = %d\n",param.p3);
- printf("wnn_flag = %d\n",param.p4);
- printf("wnn_jisho = %d\n",param.p5);
- printf("wnn_sbn = %d\n",param.p6);
- printf("wnn_dbn_len = %d\n",param.p7);
- printf("wnn_sbn_cnt = %d\n",param.p8);
- printf("wnn_suuji = %d\n",param.p9);
- printf("wnn_kana = %d\n",param.p10);
- printf("wnn_eisuu = %d\n",param.p11);
- printf("wnn_kigou = %d\n",param.p12);
- printf("wnn_toji_kakko = %d\n",param.p13);
- printf("wnn_fuzokogo = %d\n",param.p14);
- printf("wnn_kaikakko = %d\n",param.p15);
+ printf("wnn_hindo = %d\n",param.p1);
+ printf("wnn_len = %d\n",param.p2);
+ printf("wnn_jiri = %d\n",param.p3);
+ printf("wnn_flag = %d\n",param.p4);
+ printf("wnn_jisho = %d\n",param.p5);
+ printf("wnn_sbn = %d\n",param.p6);
+ printf("wnn_dbn_len = %d\n",param.p7);
+ printf("wnn_sbn_cnt = %d\n",param.p8);
+ printf("wnn_suuji = %d\n",param.p9);
+ printf("wnn_kana = %d\n",param.p10);
+ printf("wnn_eisuu = %d\n",param.p11);
+ printf("wnn_kigou = %d\n",param.p12);
+ printf("wnn_toji_kakko = %d\n",param.p13);
+ printf("wnn_fuzokogo = %d\n",param.p14);
+ printf("wnn_kaikakko = %d\n",param.p15);
#endif
rc = jl_param_set (wnnfns_buf[snum], ¶m);
CHECK_STRING (file);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
- if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING (file)->_data) < 0)
+ if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING_DATA (file)) < 0)
return Qnil;
return Qt;
}
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
lb = lb_wnn_server_type[snum];
if (!wnnfns_buf[snum]) return Qnil;
- m2w (XSTRING (name)->_data, wbuf);
+ m2w (XSTRING_DATA (name), wbuf);
if ((cnt = jl_hinsi_list (wnnfns_buf[snum], XINT (dicno), wbuf, &area)) < 0)
return Qnil;
if (cnt == 0) return make_int (0);
int snum;
CHECK_STRING (args[0]);
CHECK_STRING (args[1]);
- if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]);
+ if (! NILP (args[3])) CHECK_STRING (args[3]);
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
GCPRO1 (*args);
gcpro1.nvars = nargs;
if(jl_fi_dic_add(wnnfns_buf[snum],
- XSTRING(args[0])->_data,
- XSTRING(args[1])->_data,
- WNN_FI_SYSTEM_DICT,
- WNN_DIC_RDONLY,
- (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW,
- 0,
- (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data,
- yes_or_no,
- puts2 ) < 0) {
+ XSTRING_DATA (args[0]),
+ XSTRING_DATA (args[1]),
+ WNN_FI_SYSTEM_DICT,
+ WNN_DIC_RDONLY,
+ NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW,
+ 0,
+ NILP (args[3]) ? 0 : XSTRING_DATA (args[3]),
+ yes_or_no,
+ puts2 ) < 0) {
UNGCPRO;
return Qnil;
}
int snum;
CHECK_STRING (args[0]);
CHECK_STRING (args[1]);
- if (!EQ(args[4], Qnil)) CHECK_STRING (args[4]);
- if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]);
+ if (! NILP (args[4])) CHECK_STRING (args[4]);
+ if (! NILP (args[5])) CHECK_STRING (args[5]);
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
GCPRO1 (*args);
gcpro1.nvars = nargs;
if(jl_fi_dic_add(wnnfns_buf[snum],
- XSTRING(args[0])->_data,
- XSTRING(args[1])->_data,
- WNN_FI_USER_DICT,
- (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW,
- (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW,
- (EQ(args[4], Qnil)) ? 0 : XSTRING(args[4])->_data,
- (EQ(args[5], Qnil)) ? 0 : XSTRING(args[5])->_data,
- yes_or_no,
- puts2 ) < 0) {
+ XSTRING_DATA (args[0]),
+ XSTRING_DATA (args[1]),
+ WNN_FI_USER_DICT,
+ NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW,
+ NILP (args[3]) ? WNN_DIC_RDONLY : WNN_DIC_RW,
+ NILP (args[4]) ? 0 : XSTRING_DATA (args[4]),
+ NILP (args[5]) ? 0 : XSTRING_DATA (args[5]),
+ yes_or_no,
+ puts2 ) < 0) {
UNGCPRO;
return Qnil;
}
struct wnn_henkan_env henv;
CHECK_STRING (args[0]);
CHECK_INT (args[1]);
- if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]);
+ if (! NILP (args[3])) CHECK_STRING (args[3]);
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
GCPRO1 (*args);
dic_no = js_get_autolearning_dic(cur_env, WNN_MUHENKAN_LEARNING);
if (dic_no == WNN_NO_LEARNING) {
if((dic_no = jl_dic_add(wnnfns_buf[snum],
- XSTRING(args[0])->_data,
+ XSTRING_DATA (args[0]),
0,
wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV,
XINT(args[1]),
WNN_DIC_RW, WNN_DIC_RW,
- (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data,
+ NILP (args[3]) ? 0 : XSTRING_DATA (args[3]),
0,
yes_or_no,
puts2)) < 0) {
}
}
vmask |= WNN_ENV_MUHENKAN_LEARN_MASK;
- henv.muhenkan_flag = (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW;
+ henv.muhenkan_flag = NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) {
struct wnn_henkan_env henv;
CHECK_STRING (args[0]);
CHECK_INT (args[1]);
- if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]);
+ if (! NILP (args[3])) CHECK_STRING (args[3]);
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
GCPRO1 (*args);
dic_no = js_get_autolearning_dic(cur_env, WNN_BUNSETSUGIRI_LEARNING);
if (dic_no == WNN_NO_LEARNING) {
if((dic_no = jl_dic_add(wnnfns_buf[snum],
- XSTRING(args[0])->_data,
+ XSTRING_DATA (args[0]),
0,
wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV,
XINT(args[1]),
WNN_DIC_RW, WNN_DIC_RW,
- (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data,
+ NILP (args[3]) ? 0 : XSTRING_DATA (args[3]),
0,
yes_or_no,
puts2)) < 0) {
}
}
vmask |= WNN_ENV_BUNSETSUGIRI_LEARN_MASK;
- henv.bunsetsugiri_flag = (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW;
+ henv.bunsetsugiri_flag = NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) {
struct wnn_henkan_env henv;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
- vmask |= WNN_ENV_LAST_IS_FIRST_MASK;
- henv.last_is_first_flag = (EQ(mode, Qnil)) ? False : True;
+ vmask |= WNN_ENV_LAST_IS_FIRST_MASK;
+ henv.last_is_first_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
vmask |= WNN_ENV_COMPLEX_CONV_MASK;
- henv.complex_flag = (EQ(mode, Qnil)) ? False : True;
+ henv.complex_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
vmask |= WNN_ENV_OKURI_LEARN_MASK;
- henv.okuri_learn_flag = (EQ(mode, Qnil)) ? False : True;
+ henv.okuri_learn_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
vmask |= WNN_ENV_PREFIX_LEARN_MASK;
- henv.prefix_learn_flag = (EQ(mode, Qnil)) ? False : True;
+ henv.prefix_learn_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
vmask |= WNN_ENV_SUFFIX_LEARN_MASK;
- henv.suffix_learn_flag = (EQ(mode, Qnil)) ? False : True;
+ henv.suffix_learn_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
vmask |= WNN_ENV_COMMON_LAERN_MASK;
- henv.common_learn_flag = (EQ(mode, Qnil)) ? False : True;
+ henv.common_learn_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
if ((snum = check_wnn_server_type()) == -1) return Qnil;
if(!wnnfns_buf[snum]) return Qnil;
vmask |= WNN_ENV_YURAGI_MASK;
- henv.yuragi_flag = (EQ(mode, Qnil)) ? False : True;
+ henv.yuragi_flag = NILP (mode) ? False : True;
if(jl_set_henkan_env(wnnfns_buf[snum],
vmask,
&henv) < 0) return Qnil;
CHECK_STRING (name);
if ((snum = check_wnn_server_type ()) == -1) return Qnil;
if (!wnnfns_buf[snum]) return Qnil;
- m2w (XSTRING (name)->_data, w_buf);
+ m2w (XSTRING_DATA (name), w_buf);
if ((no = jl_hinsi_number (wnnfns_buf[snum], w_buf)) < 0) return Qnil;
return make_int (no);
}
if (EQ(Vwnn_server_type, Qcserver))
{
len = cwnn_yincod_pzy (pzy, wc,
- (EQ(Vcwnn_zhuyin, Qnil))
+ NILP (Vcwnn_zhuyin)
? CWNN_PINYIN
: CWNN_ZHUYIN);
for (i = 0; i < len; i++)
m2w (unsigned char *mp, w_char *wp)
{
unsigned int ch;
-
+
while ((ch = *mp++) != 0)
{
if (BUFBYTE_LEADING_BYTE_P (ch))
w++; pin++;
}
len = cwnn_pzy_yincod (ybuf, pbuf,
- (EQ(Vcwnn_zhuyin, Qnil)) ? CWNN_PINYIN : CWNN_ZHUYIN);
+ NILP (Vcwnn_zhuyin) ? CWNN_PINYIN : CWNN_ZHUYIN);
if (len <= 0)
return;
#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;
COLOR_INSTANCE_MSWINDOWS_COLOR (c) = color;
return 1;
}
- maybe_signal_simple_error ("unrecognized color", name, Qcolor, errb);
+ maybe_signal_simple_error ("Unrecognized color", name, Qcolor, errb);
return(0);
}
tty_mark_color_instance (struct Lisp_Color_Instance *c,
void (*markobj) (Lisp_Object))
{
- ((markobj) (COLOR_INSTANCE_TTY_SYMBOL (c)));
+ markobj (COLOR_INSTANCE_TTY_SYMBOL (c));
}
static void
tty_mark_font_instance (struct Lisp_Font_Instance *f,
void (*markobj) (Lisp_Object))
{
- ((markobj) (FONT_INSTANCE_TTY_CHARSET (f)));
+ markobj (FONT_INSTANCE_TTY_CHARSET (f));
}
static void
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:/...
#define MSWINDOWS_EOL_CURSOR_WIDTH 5
/*
- * Random forward delarations
+ * Random forward declarations
*/
static void mswindows_update_dc (HDC hdc, Lisp_Object font, Lisp_Object fg,
Lisp_Object bg, Lisp_Object bg_pmap);
Given a display line, a block number for that start line, output all
runes between start and end in the specified display block.
- Ripped off with mininmal thought from the corresponding X routine.
+ Ripped off with minimal thought from the corresponding X routine.
****************************************************************************/
static void
mswindows_output_display_block (struct window *w, struct display_line *dl, int block,
/* Draw a shadow around the divider */
if (shadow != 0)
{
- /* #### This will be fixed to support arbitrary thichkness */
+ /* #### This will be fixed to support arbitrary thickness */
InflateRect (&rect, abs_shadow, abs_shadow);
DrawEdge (FRAME_MSWINDOWS_DC (f), &rect,
shadow > 0 ? EDGE_RAISED : EDGE_SUNKEN, BF_RECT);
#include <config.h>
#include "lisp.h"
-#include "debug.h"
#include "buffer.h"
#include "window.h"
#include "redisplay.h"
#include "faces.h"
-#include "sysdep.h"
-
static int compare_runes (struct window *w, struct rune *crb,
struct rune *drb);
static void redraw_cursor_in_window (struct window *w,
a TEXT block. */
if (ddl->modeline)
{
- /* The shadow thickness check is necesssary if only the sign of
+ /* The shadow thickness check is necessary if only the sign of
the size changed. */
if (cdba && !w->shadow_thickness_changed)
{
elt++;
}
}
- /* #### RUNE_HLINE is actualy a little more complicated than this
+ /* #### RUNE_HLINE is actually a little more complicated than this
but at the moment it is only used to draw a turned off
modeline and this will suffice for that. */
else if (rb->type == RUNE_BLANK || rb->type == RUNE_HLINE)
{
/* Ensure the gray bitmap exists */
if (DEVICE_X_GRAY_PIXMAP (d) == None)
- DEVICE_X_GRAY_PIXMAP (d) =
+ DEVICE_X_GRAY_PIXMAP (d) =
XCreateBitmapFromData (dpy, x_win, (char *)gray_bits,
gray_width, gray_height);
unsigned long mask;
int x, y1, y2, width, shadow_thickness, spacing, line_width;
face_index div_face = get_builtin_face_cache_index (w, Vvertical_divider_face);
-
+
width = window_divider_width (w);
shadow_thickness = XINT (w->vertical_divider_shadow_thickness);
spacing = XINT (w->vertical_divider_spacing);
x = WINDOW_RIGHT (w) - width;
y1 = WINDOW_TOP (w);
y2 = WINDOW_BOTTOM (w);
-
+
memset (&gcv, ~0, sizeof (XGCValues));
-
+
tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face);
tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel));
-
+
/* First, get the GC's. */
top_shadow_pixel = tmp_color.pixel;
bottom_shadow_pixel = tmp_color.pixel;
background_pixel = tmp_color.pixel;
-
+
x_generate_shadow_pixels (f, &top_shadow_pixel, &bottom_shadow_pixel,
background_pixel, ef->core.background_pixel);
-
+
tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, div_face);
tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel));
gcv.background = tmp_color.pixel;
mask = GCForeground | GCBackground | GCGraphicsExposures;
/* If we can't distinguish one of the shadows (the color is the same as the
- background), it's better to use a pixmap to generate a dithrered gray. */
+ background), it's better to use a pixmap to generate a dithered gray. */
if (top_shadow_pixel == background_pixel ||
bottom_shadow_pixel == background_pixel)
use_pixmap = 1;
-
+
if (use_pixmap)
{
if (DEVICE_X_GRAY_PIXMAP (d) == None)
XCreatePixmapFromBitmapData (dpy, x_win, (char *) gray_bits,
gray_width, gray_height, 1, 0, 1);
}
-
+
tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face);
tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel));
gcv.foreground = tmp_color.pixel;
gcv.stipple = DEVICE_X_GRAY_PIXMAP (d);
top_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv,
(mask | GCStipple | GCFillStyle));
-
+
tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, div_face);
tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel));
bottom_shadow_pixel = tmp_color.pixel;
-
+
flip_gcs = (bottom_shadow_pixel ==
WhitePixelOfScreen (DefaultScreenOfDisplay (dpy)));
}
gcv.foreground = top_shadow_pixel;
top_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask);
}
-
+
gcv.foreground = bottom_shadow_pixel;
bottom_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask);
-
+
if (use_pixmap && flip_gcs)
{
GC tmp_gc = bottom_shadow_gc;
bottom_shadow_gc = top_shadow_gc;
top_shadow_gc = tmp_gc;
}
-
+
gcv.foreground = background_pixel;
background_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask);
-
+
/* possibly revert the GC's in case the shadow thickness is < 0.
This will give a depressed look to the divider */
if (shadow_thickness < 0)
temp = top_shadow_gc;
top_shadow_gc = bottom_shadow_gc;
bottom_shadow_gc = temp;
-
- /* better avoid a Bad Adress XLib error ;-) */
+
+ /* better avoid a Bad Address XLib error ;-) */
shadow_thickness = - shadow_thickness;
}
XClearArea (dpy, x_win, x, y1, width, y2 - y1, False);
/* Draw the divider line. */
- XFillRectangle (dpy, x_win, background_gc,
+ XFillRectangle (dpy, x_win, background_gc,
x + spacing + shadow_thickness, y1,
line_width, y2 - y1);
-
+
/* Draw the shadows around the divider line */
- x_output_shadows (f, x + spacing, y1,
+ x_output_shadows (f, x + spacing, y1,
width - 2 * spacing, y2 - y1,
top_shadow_gc, bottom_shadow_gc,
background_gc, shadow_thickness);
x_output_shadows
Draw a shadow around the given area using the given GC's. It is the
- callers responsibility to ste the GC's appropriately.
+ callers responsibility to set the GC's appropriately.
****************************************************************************/
void
x_output_shadows (struct frame *f, int x, int y, int width, int height,
#include "commands.h"
#include "debug.h"
#include "device.h"
+#include "elhash.h"
#include "extents.h"
#include "faces.h"
#include "frame.h"
like:
a) A 256-entry vector, for backward compatibility
- b) Some sort of hashtable, mapping characters to values
+ b) Some sort of hash table, mapping characters to values
c) A list that specifies a range of values and the
mapping to provide for those values.
{
/* If data.start_col_enabled is still true, then the window is
scrolled far enough so that nothing on this line is visible.
- We need to stick a trunctation glyph at the beginning of the
+ We need to stick a truncation glyph at the beginning of the
line in that case unless the line is completely blank. */
if (data.bi_start_col_enabled)
{
they should start. The inside margin glyphs get whatever space
is left after the whitespace glyphs have been displayed. These
are tricky to calculate since if we decide to use the overflow
- area we basicaly have to start over. So for these we build up a
+ area we basically have to start over. So for these we build up a
list of just the inside margin glyphs and manipulate it to
determine the needed info. */
{
struct glyph_block *gb = Dynarr_atp (dl->left_glyphs, elt);
if (NILP (gb->extent))
- abort (); /* these should have beeb handled in add_glyph_rune */
+ abort (); /* these should have been handled in add_glyph_rune */
if (extent_begin_glyph_layout (XEXTENT (gb->extent)) ==
GL_OUTSIDE_MARGIN)
they should start. The inside margin glyphs get whatever space
is left after the whitespace glyphs have been displayed. These
are tricky to calculate since if we decide to use the overflow
- area we basicaly have to start over. So for these we build up a
+ area we basically have to start over. So for these we build up a
list of just the inside margin glyphs and manipulate it to
determine the needed info. */
{
struct glyph_block *gb = Dynarr_atp (dl->right_glyphs, elt);
if (NILP (gb->extent))
- abort (); /* these should have beeb handled in add_glyph_rune */
+ abort (); /* these should have been handled in add_glyph_rune */
if (extent_end_glyph_layout (XEXTENT (gb->extent)) == GL_OUTSIDE_MARGIN)
{
MODELINE_INDEX, min_pixpos, max_pixpos, type);
/* The modeline is at the bottom of the gutters. We have to wait to
- set this until we've generated teh modeline in order to account
+ set this until we've generated the modeline in order to account
for any embedded faces. */
dl->ypos = WINDOW_BOTTOM (w) - dl->descent - ypos_adj;
}
Fset_marker (w->pointm[DESIRED_DISP], make_int (pointm),
the_buffer);
- /* #### BUFU amounts of overkil just to get the cursor
+ /* #### BUFU amounts of overkill just to get the cursor
location marked properly. FIX ME FIX ME FIX ME */
regenerate_window (w, startp, pointm, DESIRED_DISP);
}
redisplay_output_window (w);
/*
* If we just displayed the echo area, the line start cache is
- * no longer valid, because the minibuffer window is assocaited
+ * no longer valid, because the minibuffer window is associated
* with the window now.
*/
if (echo_active)
change_frame_size (f, f->new_height, f->new_width, 0);
/* If frame size might need to be changed, due to changed size
- of toolbars, scroolabrs etc, change it now */
+ of toolbars, scrollbars etc, change it now */
if (f->size_slipped)
{
adjust_frame_size (f);
assert (!f->size_slipped);
}
-
+
/* The menubar, toolbar, and icon updates must be done before
hold_frame_size_changes is called and we are officially
'in_display'. They may eval lisp code which may call Fsignal.
{
struct device *d = XDEVICE (XFRAME (w->frame)->device);
struct buffer *b = XBUFFER (w->buffer);
- /* Be careful in the order of these tests. The first clasue will
+ /* Be careful in the order of these tests. The first clause will
fail if DEVICE_SELECTED_FRAME == Qnil (since w->frame cannot be).
- This can occur when the frame title is computed really early */
+ This can occur when the frame title is computed really early */
Bufpos pos =
((EQ(DEVICE_SELECTED_FRAME(d), w->frame) &&
(w == XWINDOW (FRAME_SELECTED_WINDOW (device_selected_frame(d)))) &&
for (; gb < gb_last; gb++)
{
- if (!NILP (gb->glyph)) ((markobj) (gb->glyph));
- if (!NILP (gb->extent)) ((markobj) (gb->extent));
+ if (!NILP (gb->glyph))
+ markobj (gb->glyph);
+ if (!NILP (gb->extent))
+ markobj (gb->extent);
}
}
}
if (r->type == RUNE_DGLYPH)
{
if (!NILP (r->object.dglyph.glyph))
- ((markobj) (r->object.dglyph.glyph));
+ markobj (r->object.dglyph.glyph);
if (!NILP (r->object.dglyph.extent))
- ((markobj) (r->object.dglyph.extent));
+ markobj (r->object.dglyph.extent);
}
}
}
size changes can cause text shifting. However, the extent
covering the region is constantly having its face set and
priority altered by the mouse code. This means that the line
- start cache is constanty being invalidated. This is bad
+ start cache is constantly being invalidated. This is bad
since the mouse code also triggers heavy usage of the cache.
Since it is an unlikely that f->extents being changed
indicates that the cache really needs to be updated and if it
/*
* Handle invisible text properly:
- * If the last line we're inserting has the same end as the
+ * If the last line we're inserting has the same end as the
* line before which it will be added, merge the two lines.
*/
if (Dynarr_length (cache) &&
d->pixel_to_glyph_cache.obj1 = *obj1; \
d->pixel_to_glyph_cache.obj2 = *obj2; \
d->pixel_to_glyph_cache.retval = position; \
- RETURN__ position; \
+ RETURN_SANS_WARNINGS position; \
} while (0)
/* Given x and y coordinates in pixels relative to a frame, return
{
if (WINDOWP (locale))
{
- struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (locale)));
- MARK_FRAME_GLYPHS_CHANGED (f);
+ MARK_FRAME_GLYPHS_CHANGED (XFRAME (WINDOW_FRAME (XWINDOW (locale))));
}
else if (FRAMEP (locale))
{
- struct frame *f = XFRAME (locale);
- MARK_FRAME_GLYPHS_CHANGED (f);
+ MARK_FRAME_GLYPHS_CHANGED (XFRAME (locale));
}
else if (DEVICEP (locale))
{
Lisp_Object frmcons;
DEVICE_FRAME_LOOP (frmcons, XDEVICE (locale))
- {
- struct frame *f = XFRAME (XCAR (frmcons));
- MARK_FRAME_GLYPHS_CHANGED (f);
- }
+ MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons)));
}
else if (CONSOLEP (locale))
{
Lisp_Object frmcons, devcons;
CONSOLE_FRAME_LOOP_NO_BREAK (frmcons, devcons, XCONSOLE (locale))
- {
- struct frame *f = XFRAME (XCAR (frmcons));
- MARK_FRAME_GLYPHS_CHANGED (f);
- }
+ MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons)));
}
else /* global or buffer */
{
Lisp_Object frmcons, devcons, concons;
FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
- {
- struct frame *f = XFRAME (XCAR (frmcons));
- MARK_FRAME_GLYPHS_CHANGED (f);
- }
+ MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons)));
}
}
Minimum pixel height for clipped bottom display line.
A clipped line shorter than this won't be displayed.
*/ ,
- redisplay_variable_changed);
+ redisplay_variable_changed);
vertical_clip = 5;
DEFVAR_INT_MAGIC ("pixel-horizontal-clip-threshold", &horizontal_clip /*
Clipped glyphs shorter than this won't be displayed.
Only pixmap glyph instances are currently allowed to be clipped.
*/ ,
- redisplay_variable_changed);
+ redisplay_variable_changed);
horizontal_clip = 5;
DEFVAR_LISP ("global-mode-string", &Vglobal_mode_string /*
Marker for where to display an arrow on top of the buffer text.
This must be the beginning of a line in order to work.
See also `overlay-arrow-string'.
-*/ , redisplay_variable_changed);
+*/ ,
+ redisplay_variable_changed);
Voverlay_arrow_position = Qnil;
DEFVAR_LISP_MAGIC ("overlay-arrow-string", &Voverlay_arrow_string /*
String to display as an arrow. See also `overlay-arrow-position'.
*/ ,
- redisplay_variable_changed);
+ redisplay_variable_changed);
Voverlay_arrow_string = Qnil;
DEFVAR_INT ("scroll-step", &scroll_step /*
&truncate_partial_width_windows /*
*Non-nil means truncate lines in all windows less than full frame wide.
*/ ,
- redisplay_variable_changed);
+ redisplay_variable_changed);
truncate_partial_width_windows = 1;
DEFVAR_BOOL ("visible-bell", &visible_bell /*
/* CHAR */
struct
{
- Emchar ch; /* Cbaracter of this rune. */
+ Emchar ch; /* Character of this rune. */
} chr;
/* HLINE */
int cursor_elt; /* rune block of TEXT display
block cursor is at or -1 */
char used_prop_data; /* can't incrementally update if line
- used propogation data */
+ used propagation data */
layout_bounds bounds; /* line boundary positions */
if each has already been called and don't bother doing most of the
work if it is currently set. */
-#define MARK_TYPE_CHANGED(object) do { \
- if (!object##_changed_set) { \
- Lisp_Object _devcons_, _concons_; \
- DEVICE_LOOP_NO_BREAK (_devcons_, _concons_) \
- { \
- Lisp_Object _frmcons_; \
- struct device *_d_ = XDEVICE (XCAR (_devcons_)); \
- DEVICE_FRAME_LOOP (_frmcons_, _d_) \
- { \
- struct frame *_f_ = XFRAME (XCAR (_frmcons_)); \
- _f_->object##_changed = 1; \
- _f_->modiff++; \
- } \
- _d_->object##_changed = 1; \
- } \
- object##_changed = 1; \
- object##_changed_set = 1; } \
+#define MARK_TYPE_CHANGED(object) do { \
+ if (!object##_changed_set) { \
+ Lisp_Object MTC_devcons, MTC_concons; \
+ DEVICE_LOOP_NO_BREAK (MTC_devcons, MTC_concons) \
+ { \
+ Lisp_Object MTC_frmcons; \
+ struct device *MTC_d = XDEVICE (XCAR (MTC_devcons)); \
+ DEVICE_FRAME_LOOP (MTC_frmcons, MTC_d) \
+ { \
+ struct frame *MTC_f = XFRAME (XCAR (MTC_frmcons)); \
+ MTC_f->object##_changed = 1; \
+ MTC_f->modiff++; \
+ } \
+ MTC_d->object##_changed = 1; \
+ } \
+ object##_changed = 1; \
+ object##_changed_set = 1; } \
} while (0)
#define MARK_BUFFERS_CHANGED MARK_TYPE_CHANGED (buffers)
/* Anytime a console, device or frame is added or deleted we need to reset
these flags. */
-#define RESET_CHANGED_SET_FLAGS \
- do { \
- buffers_changed_set = 0; \
- clip_changed_set = 0; \
- extents_changed_set = 0; \
- icon_changed_set = 0; \
- menubar_changed_set = 0; \
- modeline_changed_set = 0; \
- point_changed_set = 0; \
- toolbar_changed_set = 0; \
- glyphs_changed_set = 0; \
+#define RESET_CHANGED_SET_FLAGS \
+ do { \
+ buffers_changed_set = 0; \
+ clip_changed_set = 0; \
+ extents_changed_set = 0; \
+ icon_changed_set = 0; \
+ menubar_changed_set = 0; \
+ modeline_changed_set = 0; \
+ point_changed_set = 0; \
+ toolbar_changed_set = 0; \
+ glyphs_changed_set = 0; \
} while (0)
\f
/* redisplay global variables */
/*************************************************************************/
-/* redisplay structre used by various utility routines. */
+/* redisplay structure used by various utility routines. */
extern display_line_dynarr *cmotion_display_lines;
/* Nonzero means truncate lines in all windows less wide than the frame. */
extern int display_arg;
/* Type of display specified. Defined in emacs.c. */
-extern char *display_use;
+extern CONST char *display_use;
/* Nonzero means reading single-character input with prompt
so put cursor on minibuffer after the prompt. */
DEBUG_PRINT2 (" Pushing reg: %d\n", this_reg); \
DEBUG_STATEMENT (num_regs_pushed++); \
\
- DEBUG_PRINT2 (" start: 0x%p\n", regstart[this_reg]); \
+ DEBUG_PRINT2 (" start: 0x%lx\n", (long) regstart[this_reg]); \
PUSH_FAILURE_POINTER (regstart[this_reg]); \
\
- DEBUG_PRINT2 (" end: 0x%p\n", regend[this_reg]); \
+ DEBUG_PRINT2 (" end: 0x%lx\n", (long) regend[this_reg]); \
PUSH_FAILURE_POINTER (regend[this_reg]); \
\
DEBUG_PRINT2 (" info: 0x%lx\n ", \
- * (unsigned long *) (®_info[this_reg])); \
+ * (long *) (®_info[this_reg])); \
DEBUG_PRINT2 (" match_null=%d", \
REG_MATCH_NULL_STRING_P (reg_info[this_reg])); \
DEBUG_PRINT2 (" active=%d", IS_ACTIVE (reg_info[this_reg])); \
DEBUG_PRINT2 (" Pushing high active reg: %d\n", highest_active_reg);\
PUSH_FAILURE_INT (highest_active_reg); \
\
- DEBUG_PRINT2 (" Pushing pattern 0x%p: ", pattern_place); \
+ DEBUG_PRINT2 (" Pushing pattern 0x%lx: ", (long) pattern_place); \
DEBUG_PRINT_COMPILED_PATTERN (bufp, pattern_place, pend); \
PUSH_FAILURE_POINTER (pattern_place); \
\
- DEBUG_PRINT2 (" Pushing string 0x%p: `", string_place); \
+ DEBUG_PRINT2 (" Pushing string 0x%lx: `", (long) string_place); \
DEBUG_PRINT_DOUBLE_STRING (string_place, string1, size1, string2, \
size2); \
DEBUG_PRINT1 ("'\n"); \
if (string_temp != NULL) \
str = (CONST char *) string_temp; \
\
- DEBUG_PRINT2 (" Popping string 0x%p: `", str); \
+ DEBUG_PRINT2 (" Popping string 0x%lx: `", (long) str); \
DEBUG_PRINT_DOUBLE_STRING (str, string1, size1, string2, size2); \
DEBUG_PRINT1 ("'\n"); \
\
pat = (unsigned char *) POP_FAILURE_POINTER (); \
- DEBUG_PRINT2 (" Popping pattern 0x%p: ", pat); \
+ DEBUG_PRINT2 (" Popping pattern 0x%lx: ", (long) pat); \
DEBUG_PRINT_COMPILED_PATTERN (bufp, pat, pend); \
\
/* Restore register info. */ \
\
reg_info[this_reg].word = POP_FAILURE_ELT (); \
DEBUG_PRINT2 (" info: 0x%lx\n", \
- * (unsigned long *) ®_info[this_reg]); \
+ * (long *) ®_info[this_reg]); \
\
regend[this_reg] = (CONST char *) POP_FAILURE_POINTER (); \
- DEBUG_PRINT2 (" end: 0x%p\n", regend[this_reg]); \
+ DEBUG_PRINT2 (" end: 0x%lx\n", (long) regend[this_reg]); \
\
regstart[this_reg] = (CONST char *) POP_FAILURE_POINTER (); \
- DEBUG_PRINT2 (" start: 0x%p\n", regstart[this_reg]); \
+ DEBUG_PRINT2 (" start: 0x%lx\n", (long) regstart[this_reg]); \
} \
\
set_regs_matched_done = 0; \
return syntax & RE_NO_EMPTY_RANGES ? REG_ERANGE : REG_NOERROR;
/* Can't have ranges spanning different charsets, except maybe for
- ranges entirely witin the first 256 chars. */
+ ranges entirely within the first 256 chars. */
if ((range_start >= 0x100 || range_end >= 0x100)
&& CHAR_LEADING_BYTE (range_start) !=
fails at this starting point in the input data. */
for (;;)
{
- DEBUG_PRINT2 ("\n0x%p: ", p);
+ DEBUG_PRINT2 ("\n0x%lx: ", (long) p);
#ifdef emacs /* XEmacs added, w/removal of immediate_quit */
if (!no_quit_in_re_search)
QUIT;
DEBUG_PRINT1 ("EXECUTING on_failure_keep_string_jump");
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- DEBUG_PRINT3 (" %d (to 0x%p):\n", mcnt, p + mcnt);
+ DEBUG_PRINT3 (" %d (to 0x%lx):\n", mcnt, (long) (p + mcnt));
PUSH_FAILURE_POINT (p + mcnt, (char *) 0, -2);
break;
DEBUG_PRINT1 ("EXECUTING on_failure_jump");
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- DEBUG_PRINT3 (" %d (to 0x%p)", mcnt, p + mcnt);
+ DEBUG_PRINT3 (" %d (to 0x%lx)", mcnt, (long) (p + mcnt));
/* If this on_failure_jump comes right before a group (i.e.,
the original * applied to a group), save the information
EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */
DEBUG_PRINT2 ("EXECUTING jump %d ", mcnt);
p += mcnt; /* Do the jump. */
- DEBUG_PRINT2 ("(to 0x%p).\n", p);
+ DEBUG_PRINT2 ("(to 0x%lx).\n", (long) p);
break;
mcnt--;
p += 2;
STORE_NUMBER_AND_INCR (p, mcnt);
- DEBUG_PRINT3 (" Setting 0x%p to %d.\n", p, mcnt);
+ DEBUG_PRINT3 (" Setting 0x%lx to %d.\n", (long) p, mcnt);
}
else if (mcnt == 0)
{
- DEBUG_PRINT2 (" Setting two bytes from 0x%p to no_op.\n", p+2);
+ DEBUG_PRINT2 (" Setting two bytes from 0x%lx to no_op.\n",
+ (long) (p+2));
p[2] = (unsigned char) no_op;
p[3] = (unsigned char) no_op;
goto on_failure;
EXTRACT_NUMBER_AND_INCR (mcnt, p);
p1 = p + mcnt;
EXTRACT_NUMBER_AND_INCR (mcnt, p);
- DEBUG_PRINT3 (" Setting 0x%p to %d.\n", p1, mcnt);
+ DEBUG_PRINT3 (" Setting 0x%lx to %d.\n", (long) p1, mcnt);
STORE_NUMBER (p1, mcnt);
break;
}
#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);
#include "lisp.h"
#include "buffer.h"
-#include "commands.h"
#include "insdel.h"
#include "opaque.h"
#ifdef REGION_CACHE_NEEDS_WORK
}
Bytind
-bi_find_next_newline_no_quit (struct buffer *buf, Bytind from, int cnt)
+bi_find_next_newline_no_quit (struct buffer *buf, Bytind from, int count)
{
- return bi_scan_buffer (buf, '\n', from, 0, cnt, 0, 0);
+ return bi_scan_buffer (buf, '\n', from, 0, count, 0, 0);
}
Bufpos
-find_next_newline_no_quit (struct buffer *buf, Bufpos from, int cnt)
+find_next_newline_no_quit (struct buffer *buf, Bufpos from, int count)
{
- return scan_buffer (buf, '\n', from, 0, cnt, 0, 0);
+ return scan_buffer (buf, '\n', from, 0, count, 0, 0);
}
Bufpos
-find_next_newline (struct buffer *buf, Bufpos from, int cnt)
+find_next_newline (struct buffer *buf, Bufpos from, int count)
{
- return scan_buffer (buf, '\n', from, 0, cnt, 0, 1);
+ return scan_buffer (buf, '\n', from, 0, count, 0, 1);
}
/* Like find_next_newline, but returns position before the newline,
not after, and only search up to TO. This isn't just
find_next_newline (...)-1, because you might hit TO. */
Bufpos
-find_before_next_newline (struct buffer *buf, Bufpos from, Bufpos to, int cnt)
+find_before_next_newline (struct buffer *buf, Bufpos from, Bufpos to, int count)
{
EMACS_INT shortage;
- Bufpos pos = scan_buffer (buf, '\n', from, to, cnt, &shortage, 1);
+ Bufpos pos = scan_buffer (buf, '\n', from, to, count, &shortage, 1);
if (shortage == 0)
pos--;
REGISTER int i;
struct Lisp_Char_Table *syntax_table =
XCHAR_TABLE (buf->mirror_syntax_table);
-
- CHECK_STRING (string);
+ Bufpos limit;
if (NILP (lim))
- XSETINT (lim, forwardp ? BUF_ZV (buf) : BUF_BEGV (buf));
+ limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf);
else
- CHECK_INT_COERCE_MARKER (lim);
+ {
+ CHECK_INT_COERCE_MARKER (lim);
+ limit = XINT (lim);
- /* In any case, don't allow scan outside bounds of buffer. */
- if (XINT (lim) > BUF_ZV (buf))
- lim = make_int (BUF_ZV (buf));
- if (XINT (lim) < BUF_BEGV (buf))
- lim = make_int (BUF_BEGV (buf));
+ /* In any case, don't allow scan outside bounds of buffer. */
+ if (limit > BUF_ZV (buf)) limit = BUF_ZV (buf);
+ if (limit < BUF_BEGV (buf)) limit = BUF_BEGV (buf);
+ }
+ CHECK_STRING (string);
p = XSTRING_DATA (string);
pend = p + XSTRING_LENGTH (string);
memset (fastmap, 0, sizeof (fastmap));
to worry about */
if (forwardp)
{
- while (BUF_PT (buf) < XINT (lim)
+ while (BUF_PT (buf) < limit
&& fastmap[(unsigned char)
syntax_code_spec
[(int) SYNTAX (syntax_table,
}
else
{
- while (BUF_PT (buf) > XINT (lim)
+ while (BUF_PT (buf) > limit
&& fastmap[(unsigned char)
syntax_code_spec
[(int) SYNTAX (syntax_table,
{
if (forwardp)
{
- while (BUF_PT (buf) < XINT (lim))
+ while (BUF_PT (buf) < limit)
{
Emchar ch = BUF_FETCH_CHAR (buf, BUF_PT (buf));
if ((ch < 0400) ? fastmap[ch] :
}
else
{
- while (BUF_PT (buf) > XINT (lim))
+ while (BUF_PT (buf) > limit)
{
Emchar ch = BUF_FETCH_CHAR (buf, BUF_PT (buf) - 1);
if ((ch < 0400) ? fastmap[ch] :
(EMACS_UINT) p_limit)
cursor += BM_tab[*cursor];
}
-/* If you are here, cursor is beyond the end of the searched region. */
+ /* If you are here, cursor is beyond the end of the searched region. */
/* This can happen if you match on the far character of the pattern, */
/* because the "stride" of that character is infinity, a number able */
/* to throw you well beyond the end of the search. It can also */
case_action = nochange; /* We tried an initialization */
/* but some C compilers blew it */
- if (search_regs.num_regs <= 0)
+ if (search_regs.num_regs == 0)
error ("replace-match called before any match found");
if (NILP (string))
n = XINT (num);
if (n < 0 || n >= search_regs.num_regs)
args_out_of_range (num, make_int (search_regs.num_regs));
- if (search_regs.num_regs <= 0 ||
+ if (search_regs.num_regs == 0 ||
search_regs.start[n] < 0)
return Qnil;
return make_int (beginningp ? search_regs.start[n] : search_regs.end[n]);
/* If REUSE is a list, store as many value elements as will fit
into the elements of REUSE. */
- for (i = 0, tail = reuse; CONSP (tail); i++, tail = XCDR (tail))
+ for (prev = Qnil, i = 0, tail = reuse; CONSP (tail); i++, tail = XCDR (tail))
{
if (i < 2 * len + 2)
XCAR (tail) = data[i];
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;
#include "buffer.h" /* for Vbuffer_defaults */
#include "console.h"
-
-#include "elhash.h" /* for HASHTABLE_NONWEAK and HASHTABLE_EQ */
+#include "elhash.h"
Lisp_Object Qad_advice_info, Qad_activate;
Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound;
Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value;
-Lisp_Object Qset_default, Qmake_variable_buffer_local, Qmake_local_variable;
+Lisp_Object Qset_default, Qsetq_default;
+Lisp_Object Qmake_variable_buffer_local, Qmake_local_variable;
Lisp_Object Qkill_local_variable, Qkill_console_local_variable;
Lisp_Object Qsymbol_value_in_buffer, Qsymbol_value_in_console;
Lisp_Object Qlocal_variable_p;
Lisp_Object funsym,
int nargs, ...);
static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym,
- Lisp_Object
- follow_past_lisp_magic);
+ Lisp_Object follow_past_lisp_magic);
static Lisp_Object *value_slot_past_magic (Lisp_Object sym);
-static Lisp_Object follow_varalias_pointers (Lisp_Object object,
- Lisp_Object
- follow_past_lisp_magic);
+static Lisp_Object follow_varalias_pointers (Lisp_Object symbol,
+ Lisp_Object follow_past_lisp_magic);
\f
#ifdef LRECORD_SYMBOL
struct Lisp_Symbol *sym = XSYMBOL (obj);
Lisp_Object pname;
- ((markobj) (sym->value));
- ((markobj) (sym->function));
+ markobj (sym->value);
+ markobj (sym->function);
/* No need to mark through ->obarray, because it only holds nil or t. */
- /*((markobj) (sym->obarray));*/
+ /* markobj (sym->obarray);*/
XSETSTRING (pname, sym->name);
- ((markobj) (pname));
+ markobj (pname);
if (!symbol_next (sym))
return sym->plist;
else
{
- ((markobj) (sym->plist));
+ markobj (sym->plist);
/* Mark the rest of the symbols in the obarray hash-chain */
sym = symbol_next (sym);
XSETSYMBOL (obj, sym);
Lisp_Object
intern (CONST char *str)
{
- Lisp_Object tem;
Bytecount len = strlen (str);
+ CONST Bufbyte *buf = (CONST Bufbyte *) str;
Lisp_Object obarray = Vobarray;
+
if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0)
obarray = check_obarray (obarray);
- tem = oblookup (obarray, (CONST Bufbyte *) str, len);
- if (SYMBOLP (tem))
- return tem;
- return Fintern (((purify_flag)
- ? make_pure_pname ((CONST Bufbyte *) str, len, 0)
- : make_string ((CONST Bufbyte *) str, len)),
+ {
+ Lisp_Object tem = oblookup (obarray, buf, len);
+ if (SYMBOLP (tem))
+ return tem;
+ }
+
+ return Fintern ((purify_flag
+ ? make_pure_pname (buf, len, 0)
+ : make_string (buf, len)),
obarray);
}
A second optional argument specifies the obarray to use;
it defaults to the value of `obarray'.
*/
- (str, obarray))
+ (string, obarray))
{
Lisp_Object sym, *ptr;
Bytecount len;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
- CHECK_STRING (str);
+ CHECK_STRING (string);
- len = XSTRING_LENGTH (str);
- sym = oblookup (obarray, XSTRING_DATA (str), len);
+ len = XSTRING_LENGTH (string);
+ sym = oblookup (obarray, XSTRING_DATA (string), len);
if (!INTP (sym))
/* Found it */
return sym;
ptr = &XVECTOR_DATA (obarray)[XINT (sym)];
- if (purify_flag && ! purified (str))
- str = make_pure_pname (XSTRING_DATA (str), len, 0);
- sym = Fmake_symbol (str);
+ if (purify_flag && ! purified (string))
+ string = make_pure_pname (XSTRING_DATA (string), len, 0);
+ sym = Fmake_symbol (string);
/* FSFmacs places OBARRAY here, but it is pointless because we do
not mark through this slot, so it is not usable later (because
the obarray might have been collected). Marking through the
A second optional argument specifies the obarray to use;
it defaults to the value of `obarray'.
*/
- (str, obarray))
+ (string, obarray))
{
Lisp_Object tem;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
- CHECK_STRING (str);
+ CHECK_STRING (string);
- tem = oblookup (obarray, XSTRING_DATA (str), XSTRING_LENGTH (str));
- if (!INTP (tem))
- return tem;
- return Qnil;
+ tem = oblookup (obarray, XSTRING_DATA (string), XSTRING_LENGTH (string));
+ return !INTP (tem) ? tem : Qnil;
}
\f
DEFUN ("unintern", Funintern, 1, 2, 0, /*
\f
/* Return the symbol in OBARRAY whose names matches the string
of SIZE characters at PTR. If there is no such symbol in OBARRAY,
- return nil.
+ return the index into OBARRAY that the string hashes to.
Also store the bucket number in oblookup_last_bucket_number. */
/* This is sometimes needed in the middle of GC. */
obsize &= ~ARRAY_MARK_FLAG;
#endif
- /* Combining next two lines breaks VMS C 2.3. */
- hash = hash_string (ptr, size);
- hash %= obsize;
- bucket = XVECTOR_DATA (obarray)[hash];
+ hash = hash_string (ptr, size) % obsize;
oblookup_last_bucket_number = hash;
+ bucket = XVECTOR_DATA (obarray)[hash];
if (ZEROP (bucket))
;
else if (!SYMBOLP (bucket))
DEFUN ("boundp", Fboundp, 1, 1, 0, /*
Return t if SYMBOL's value is not void.
*/
- (sym))
+ (symbol))
{
- CHECK_SYMBOL (sym);
- return UNBOUNDP (find_symbol_value (sym)) ? Qnil : Qt;
+ CHECK_SYMBOL (symbol);
+ return UNBOUNDP (find_symbol_value (symbol)) ? Qnil : Qt;
}
DEFUN ("globally-boundp", Fglobally_boundp, 1, 1, 0, /*
Return t if SYMBOL has a global (non-bound) value.
This is for the byte-compiler; you really shouldn't be using this.
*/
- (sym))
+ (symbol))
{
- CHECK_SYMBOL (sym);
- return UNBOUNDP (top_level_value (sym)) ? Qnil : Qt;
+ CHECK_SYMBOL (symbol);
+ return UNBOUNDP (top_level_value (symbol)) ? Qnil : Qt;
}
DEFUN ("fboundp", Ffboundp, 1, 1, 0, /*
Return t if SYMBOL's function definition is not void.
*/
- (sym))
+ (symbol))
{
- CHECK_SYMBOL (sym);
- return UNBOUNDP (XSYMBOL (sym)->function) ? Qnil : Qt;
+ CHECK_SYMBOL (symbol);
+ return UNBOUNDP (XSYMBOL (symbol)->function) ? Qnil : Qt;
}
/* Return non-zero if SYM's value or function (the current contents of
}
/* We don't return true for keywords here because they are handled
- specially by reject_constant_symbols(). */
+ specially by reject_constant_symbols(). */
return 0;
}
FOLLOW_PAST_LISP_MAGIC specifies whether we delve past
symbol-value-lisp-magic objects. */
-static void
+void
reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, int function_p,
Lisp_Object follow_past_lisp_magic)
{
DEFUN ("makunbound", Fmakunbound, 1, 1, 0, /*
Make SYMBOL's value be void.
*/
- (sym))
+ (symbol))
{
- Fset (sym, Qunbound);
- return sym;
+ Fset (symbol, Qunbound);
+ return symbol;
}
DEFUN ("fmakunbound", Ffmakunbound, 1, 1, 0, /*
Make SYMBOL's function definition be void.
*/
- (sym))
+ (symbol))
{
- CHECK_SYMBOL (sym);
- reject_constant_symbols (sym, Qunbound, 1, Qt);
- XSYMBOL (sym)->function = Qunbound;
- return sym;
+ CHECK_SYMBOL (symbol);
+ reject_constant_symbols (symbol, Qunbound, 1, Qt);
+ XSYMBOL (symbol)->function = Qunbound;
+ return symbol;
}
DEFUN ("symbol-function", Fsymbol_function, 1, 1, 0, /*
{
CHECK_SYMBOL (symbol);
if (UNBOUNDP (XSYMBOL (symbol)->function))
- return Fsignal (Qvoid_function, list1 (symbol));
+ signal_void_function_error (symbol);
return XSYMBOL (symbol)->function;
}
DEFUN ("symbol-plist", Fsymbol_plist, 1, 1, 0, /*
Return SYMBOL's property list.
*/
- (sym))
+ (symbol))
{
- CHECK_SYMBOL (sym);
- return XSYMBOL (sym)->plist;
+ CHECK_SYMBOL (symbol);
+ return XSYMBOL (symbol)->plist;
}
DEFUN ("symbol-name", Fsymbol_name, 1, 1, 0, /*
Return SYMBOL's name, a string.
*/
- (sym))
+ (symbol))
{
Lisp_Object name;
- CHECK_SYMBOL (sym);
- XSETSTRING (name, XSYMBOL (sym)->name);
+ CHECK_SYMBOL (symbol);
+ XSETSTRING (name, XSYMBOL (symbol)->name);
return name;
}
DEFUN ("fset", Ffset, 2, 2, 0, /*
Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
*/
- (sym, newdef))
+ (symbol, newdef))
{
/* This function can GC */
- CHECK_SYMBOL (sym);
- reject_constant_symbols (sym, newdef, 1, Qt);
- if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (sym)->function))
- Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function),
+ CHECK_SYMBOL (symbol);
+ reject_constant_symbols (symbol, newdef, 1, Qt);
+ if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (symbol)->function))
+ Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
Vautoload_queue);
- XSYMBOL (sym)->function = newdef;
+ XSYMBOL (symbol)->function = newdef;
/* Handle automatic advice activation */
- if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info,
- Qnil)))
+ if (CONSP (XSYMBOL (symbol)->plist) &&
+ !NILP (Fget (symbol, Qad_advice_info, Qnil)))
{
- call2 (Qad_activate, sym, Qnil);
- newdef = XSYMBOL (sym)->function;
+ call2 (Qad_activate, symbol, Qnil);
+ newdef = XSYMBOL (symbol)->function;
}
return newdef;
}
Set SYMBOL's function definition to NEWDEF, and return NEWDEF.
Associates the function with the current load file, if any.
*/
- (sym, newdef))
+ (symbol, newdef))
{
/* This function can GC */
- CHECK_SYMBOL (sym);
- Ffset (sym, newdef);
- LOADHIST_ATTACH (sym);
+ Ffset (symbol, newdef);
+ LOADHIST_ATTACH (symbol);
return newdef;
}
DEFUN ("setplist", Fsetplist, 2, 2, 0, /*
Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.
*/
- (sym, newplist))
+ (symbol, newplist))
{
- CHECK_SYMBOL (sym);
+ CHECK_SYMBOL (symbol);
#if 0 /* Inserted for debugging 6/28/1997 -slb */
/* Somebody is setting a property list of integer 0, who? */
/* Not this way apparently. */
if (EQ(newplist, Qzero)) abort();
#endif
- XSYMBOL (sym)->plist = newplist;
+ XSYMBOL (symbol)->plist = newplist;
return newplist;
}
If a symbol is "unbound", then the contents of its value cell is
Qunbound. Despite appearances, this is *not* a symbol, but is a
symbol-value-forward object. This is so that printing it results
- in "INTERNAL EMACS BUG", in case it leaks to Lisp, somehow.
+ in "INTERNAL OBJECT (XEmacs bug?)", in case it leaks to Lisp, somehow.
Logically all of the following objects are "symbol-value-magic"
objects, and there are some games played w.r.t. this (#### this
{
struct symbol_value_buffer_local *bfwd;
+#ifdef ERROR_CHECK_TYPECHECK
assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_BUFFER_LOCAL ||
XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_SOME_BUFFER_LOCAL);
+#endif
bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj);
- ((markobj) (bfwd->default_value));
- ((markobj) (bfwd->current_value));
- ((markobj) (bfwd->current_buffer));
+ markobj (bfwd->default_value);
+ markobj (bfwd->current_value);
+ markobj (bfwd->current_buffer);
return bfwd->current_alist_element;
}
bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj);
for (i = 0; i < MAGIC_HANDLER_MAX; i++)
{
- ((markobj) (bfwd->handler[i]));
- ((markobj) (bfwd->harg[i]));
+ markobj (bfwd->handler[i]);
+ markobj (bfwd->harg[i]);
}
return bfwd->shadowed;
}
assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS);
bfwd = XSYMBOL_VALUE_VARALIAS (obj);
- ((markobj) (bfwd->shadowed));
+ markobj (bfwd->shadowed);
return bfwd->aliasee;
}
Lisp_Object printcharfun, int escapeflag)
{
char buf[200];
- sprintf (buf, "#<INTERNAL EMACS BUG (%s type %d) 0x%p>",
+ sprintf (buf, "#<INTERNAL OBJECT (XEmacs bug?) (%s type %d) 0x%lx>",
XRECORD_LHEADER_IMPLEMENTATION (obj)->name,
XSYMBOL_VALUE_MAGIC_TYPE (obj),
- (void *) XPNTR (obj));
+ (long) XPNTR (obj));
write_c_string (buf, printcharfun);
}
if (mask > 0) /* Not always per-buffer */
{
- Lisp_Object tail;
+ Lisp_Object elt;
/* Set value in each buffer which hasn't shadowed the default */
- LIST_LOOP (tail, Vbuffer_alist)
+ LIST_LOOP_2 (elt, Vbuffer_alist)
{
- struct buffer *b = XBUFFER (XCDR (XCAR (tail)));
+ struct buffer *b = XBUFFER (XCDR (elt));
if (!(b->local_var_flags & mask))
{
if (magicfun)
- (magicfun) (sym, &value, make_buffer (b), 0);
+ magicfun (sym, &value, make_buffer (b), 0);
*((Lisp_Object *) (offset + (char *) b)) = value;
}
}
if (mask > 0) /* Not always per-console */
{
- Lisp_Object tail;
+ Lisp_Object console;
/* Set value in each console which hasn't shadowed the default */
- LIST_LOOP (tail, Vconsole_list)
+ LIST_LOOP_2 (console, Vconsole_list)
{
- Lisp_Object dev = XCAR (tail);
- struct console *d = XCONSOLE (dev);
+ struct console *d = XCONSOLE (console);
if (!(d->local_var_flags & mask))
{
if (magicfun)
- (magicfun) (sym, &value, dev, 0);
+ magicfun (sym, &value, console, 0);
*((Lisp_Object *) (offset + (char *) d)) = value;
}
}
|| !SYMBOL_VALUE_MAGIC_P (*store_pointer));
*store_pointer = newval;
}
-
else
{
- CONST struct symbol_value_forward *fwd
- = XSYMBOL_VALUE_FORWARD (ovalue);
- int type = XSYMBOL_VALUE_MAGIC_TYPE (ovalue);
+ CONST struct symbol_value_forward *fwd = XSYMBOL_VALUE_FORWARD (ovalue);
int (*magicfun) (Lisp_Object simm, Lisp_Object *val,
- Lisp_Object in_object, int flags) =
- symbol_value_forward_magicfun (fwd);
+ Lisp_Object in_object, int flags)
+ = symbol_value_forward_magicfun (fwd);
- switch (type)
+ switch (XSYMBOL_VALUE_MAGIC_TYPE (ovalue))
{
case SYMVAL_FIXNUM_FORWARD:
- {
- CHECK_INT (newval);
- if (magicfun)
- (magicfun) (sym, &newval, Qnil, 0);
- *((int *) symbol_value_forward_forward (fwd)) = XINT (newval);
- return;
- }
+ CHECK_INT (newval);
+ if (magicfun)
+ magicfun (sym, &newval, Qnil, 0);
+ *((int *) symbol_value_forward_forward (fwd)) = XINT (newval);
+ return;
case SYMVAL_BOOLEAN_FORWARD:
- {
- if (magicfun)
- (magicfun) (sym, &newval, Qnil, 0);
- *((int *) symbol_value_forward_forward (fwd))
- = ((NILP (newval)) ? 0 : 1);
- return;
- }
+ if (magicfun)
+ magicfun (sym, &newval, Qnil, 0);
+ *((int *) symbol_value_forward_forward (fwd))
+ = ((NILP (newval)) ? 0 : 1);
+ return;
case SYMVAL_OBJECT_FORWARD:
- {
- if (magicfun)
- (magicfun) (sym, &newval, Qnil, 0);
- *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval;
- return;
- }
+ if (magicfun)
+ magicfun (sym, &newval, Qnil, 0);
+ *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval;
+ return;
case SYMVAL_DEFAULT_BUFFER_FORWARD:
- {
- set_default_buffer_slot_variable (sym, newval);
- return;
- }
+ set_default_buffer_slot_variable (sym, newval);
+ return;
case SYMVAL_CURRENT_BUFFER_FORWARD:
- {
- if (magicfun)
- (magicfun) (sym, &newval, make_buffer (current_buffer), 0);
- *((Lisp_Object *) ((char *) current_buffer
- + ((char *) symbol_value_forward_forward (fwd)
- - (char *) &buffer_local_flags)))
- = newval;
- return;
- }
+ if (magicfun)
+ magicfun (sym, &newval, make_buffer (current_buffer), 0);
+ *((Lisp_Object *) ((char *) current_buffer
+ + ((char *) symbol_value_forward_forward (fwd)
+ - (char *) &buffer_local_flags)))
+ = newval;
+ return;
case SYMVAL_DEFAULT_CONSOLE_FORWARD:
- {
- set_default_console_slot_variable (sym, newval);
- return;
- }
+ set_default_console_slot_variable (sym, newval);
+ return;
case SYMVAL_SELECTED_CONSOLE_FORWARD:
- {
- if (magicfun)
- (magicfun) (sym, &newval, Vselected_console, 0);
- *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console)
- + ((char *) symbol_value_forward_forward (fwd)
- - (char *) &console_local_flags)))
- = newval;
- return;
- }
+ if (magicfun)
+ magicfun (sym, &newval, Vselected_console, 0);
+ *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console)
+ + ((char *) symbol_value_forward_forward (fwd)
+ - (char *) &console_local_flags)))
+ = newval;
+ return;
default:
abort ();
/* Retrieve the new alist element and new value. */
if (NILP (new_alist_el)
&& set_it_p)
- new_alist_el = buffer_local_alist_element (buf, sym, bfwd);
+ new_alist_el = buffer_local_alist_element (buf, sym, bfwd);
if (NILP (new_alist_el))
new_val = bfwd->default_value;
else if (NILP (symcons))
{
if (set_it_p)
- valcontents = assq_no_quit (sym, buf->local_var_alist);
+ valcontents = assq_no_quit (sym, buf->local_var_alist);
if (NILP (valcontents))
valcontents = bfwd->default_value;
else
CHECK_SYMBOL (sym);
- if (!NILP (buffer))
+ if (NILP (buffer))
+ buf = current_buffer;
+ else
{
CHECK_BUFFER (buffer);
buf = XBUFFER (buffer);
}
- else
- buf = current_buffer;
return find_symbol_value_1 (sym, buf,
/* If it bombs out at startup due to a
{
CHECK_SYMBOL (sym);
- if (!NILP (console))
- CHECK_CONSOLE (console);
- else
+ if (NILP (console))
console = Vselected_console;
+ else
+ CHECK_CONSOLE (console);
return find_symbol_value_1 (sym, current_buffer, XCONSOLE (console), 0,
Qnil, 1);
{
/* WARNING: This function can be called when current_buffer is 0
and Vselected_console is Qnil, early in initialization. */
- struct console *dev;
+ struct console *con;
Lisp_Object valcontents;
CHECK_SYMBOL (sym);
return valcontents;
if (CONSOLEP (Vselected_console))
- dev = XCONSOLE (Vselected_console);
+ con = XCONSOLE (Vselected_console);
else
{
/* This can also get called while we're preparing to shutdown.
#### What should really happen in that case? Should we
actually fix things so we can't get here in that case? */
assert (!initialized || preparing_for_armageddon);
- dev = 0;
+ con = 0;
}
- return find_symbol_value_1 (sym, current_buffer, dev, 1, Qnil, 1);
+ return find_symbol_value_1 (sym, current_buffer, con, 1, Qnil, 1);
}
/* This is an optimized function for quick lookup of buffer local symbols
{
/* WARNING: This function can be called when current_buffer is 0
and Vselected_console is Qnil, early in initialization. */
- struct console *dev;
+ struct console *con;
Lisp_Object sym = find_it_p ? XCAR (symbol_cons) : symbol_cons;
CHECK_SYMBOL (sym);
if (CONSOLEP (Vselected_console))
- dev = XCONSOLE (Vselected_console);
+ con = XCONSOLE (Vselected_console);
else
{
/* This can also get called while we're preparing to shutdown.
#### What should really happen in that case? Should we
actually fix things so we can't get here in that case? */
assert (!initialized || preparing_for_armageddon);
- dev = 0;
+ con = 0;
}
- return find_symbol_value_1 (sym, current_buffer, dev, 1,
+ return find_symbol_value_1 (sym, current_buffer, con, 1,
find_it_p ? symbol_cons : Qnil,
find_it_p);
}
DEFUN ("symbol-value", Fsymbol_value, 1, 1, 0, /*
Return SYMBOL's value. Error if that is void.
*/
- (sym))
+ (symbol))
{
- Lisp_Object val = find_symbol_value (sym);
+ Lisp_Object val = find_symbol_value (symbol);
if (UNBOUNDP (val))
- return Fsignal (Qvoid_variable, list1 (sym));
+ return Fsignal (Qvoid_variable, list1 (symbol));
else
return val;
}
DEFUN ("set", Fset, 2, 2, 0, /*
Set SYMBOL's value to NEWVAL, and return NEWVAL.
*/
- (sym, newval))
+ (symbol, newval))
{
REGISTER Lisp_Object valcontents;
+ struct Lisp_Symbol *sym;
/* remember, we're called by Fmakunbound() as well */
- CHECK_SYMBOL (sym);
+ CHECK_SYMBOL (symbol);
retry:
- valcontents = XSYMBOL (sym)->value;
- if (NILP (sym) || EQ (sym, Qt) || SYMBOL_VALUE_MAGIC_P (valcontents)
- || SYMBOL_IS_KEYWORD (sym))
- reject_constant_symbols (sym, newval, 0,
+ sym = XSYMBOL (symbol);
+ valcontents = sym->value;
+
+ if (EQ (symbol, Qnil) ||
+ EQ (symbol, Qt) ||
+ SYMBOL_IS_KEYWORD (symbol))
+ reject_constant_symbols (symbol, newval, 0,
UNBOUNDP (newval) ? Qmakunbound : Qset);
- else
+
+ if (!SYMBOL_VALUE_MAGIC_P (valcontents) || UNBOUNDP (valcontents))
{
- XSYMBOL (sym)->value = newval;
+ sym->value = newval;
return newval;
}
+ reject_constant_symbols (symbol, newval, 0,
+ UNBOUNDP (newval) ? Qmakunbound : Qset);
+
retry_2:
- if (SYMBOL_VALUE_MAGIC_P (valcontents))
+ switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
{
- switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
- {
- case SYMVAL_LISP_MAGIC:
- {
- Lisp_Object retval;
+ case SYMVAL_LISP_MAGIC:
+ {
+ Lisp_Object retval;
- if (UNBOUNDP (newval))
- retval = maybe_call_magic_handler (sym, Qmakunbound, 0);
- else
- retval = maybe_call_magic_handler (sym, Qset, 1, newval);
- if (!UNBOUNDP (retval))
- return newval;
- valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
- /* semi-change-o */
- goto retry_2;
- }
+ if (UNBOUNDP (newval))
+ retval = maybe_call_magic_handler (symbol, Qmakunbound, 0);
+ else
+ retval = maybe_call_magic_handler (symbol, Qset, 1, newval);
+ if (!UNBOUNDP (retval))
+ return newval;
+ valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
+ /* semi-change-o */
+ goto retry_2;
+ }
- case SYMVAL_VARALIAS:
- sym = follow_varalias_pointers (sym,
- UNBOUNDP (newval)
- ? Qmakunbound : Qset);
- /* presto change-o! */
- goto retry;
+ case SYMVAL_VARALIAS:
+ symbol = follow_varalias_pointers (symbol,
+ UNBOUNDP (newval)
+ ? Qmakunbound : Qset);
+ /* presto change-o! */
+ goto retry;
- case SYMVAL_FIXNUM_FORWARD:
- case SYMVAL_BOOLEAN_FORWARD:
- case SYMVAL_OBJECT_FORWARD:
- case SYMVAL_DEFAULT_BUFFER_FORWARD:
- case SYMVAL_DEFAULT_CONSOLE_FORWARD:
- if (UNBOUNDP (newval))
- signal_error (Qerror,
- list2 (build_string ("Cannot makunbound"), sym));
- break;
+ case SYMVAL_FIXNUM_FORWARD:
+ case SYMVAL_BOOLEAN_FORWARD:
+ case SYMVAL_OBJECT_FORWARD:
+ case SYMVAL_DEFAULT_BUFFER_FORWARD:
+ case SYMVAL_DEFAULT_CONSOLE_FORWARD:
+ if (UNBOUNDP (newval))
+ signal_error (Qerror,
+ list2 (build_string ("Cannot makunbound"), symbol));
+ break;
- case SYMVAL_UNBOUND_MARKER:
- break;
+ /* case SYMVAL_UNBOUND_MARKER: break; */
- case SYMVAL_CURRENT_BUFFER_FORWARD:
- {
- CONST struct symbol_value_forward *fwd
- = XSYMBOL_VALUE_FORWARD (valcontents);
- int mask = XINT (*((Lisp_Object *)
- symbol_value_forward_forward (fwd)));
- if (mask > 0)
- /* Setting this variable makes it buffer-local */
- current_buffer->local_var_flags |= mask;
- break;
- }
+ case SYMVAL_CURRENT_BUFFER_FORWARD:
+ {
+ CONST struct symbol_value_forward *fwd
+ = XSYMBOL_VALUE_FORWARD (valcontents);
+ int mask = XINT (*((Lisp_Object *)
+ symbol_value_forward_forward (fwd)));
+ if (mask > 0)
+ /* Setting this variable makes it buffer-local */
+ current_buffer->local_var_flags |= mask;
+ break;
+ }
- case SYMVAL_SELECTED_CONSOLE_FORWARD:
+ case SYMVAL_SELECTED_CONSOLE_FORWARD:
+ {
+ CONST struct symbol_value_forward *fwd
+ = XSYMBOL_VALUE_FORWARD (valcontents);
+ int mask = XINT (*((Lisp_Object *)
+ symbol_value_forward_forward (fwd)));
+ if (mask > 0)
+ /* Setting this variable makes it console-local */
+ XCONSOLE (Vselected_console)->local_var_flags |= mask;
+ break;
+ }
+
+ case SYMVAL_BUFFER_LOCAL:
+ case SYMVAL_SOME_BUFFER_LOCAL:
+ {
+ /* If we want to examine or set the value and
+ CURRENT-BUFFER is current, we just examine or set
+ CURRENT-VALUE. If CURRENT-BUFFER is not current, we
+ store the current CURRENT-VALUE value into
+ CURRENT-ALIST- ELEMENT, then find the appropriate alist
+ element for the buffer now current and set up
+ CURRENT-ALIST-ELEMENT. Then we set CURRENT-VALUE out
+ of that element, and store into CURRENT-BUFFER.
+
+ If we are setting the variable and the current buffer does
+ not have an alist entry for this variable, an alist entry is
+ created.
+
+ Note that CURRENT-VALUE can be a forwarding pointer.
+ Each time it is examined or set, forwarding must be
+ done. */
+ struct symbol_value_buffer_local *bfwd
+ = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
+ int some_buffer_local_p =
+ (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL);
+ /* What value are we caching right now? */
+ Lisp_Object aelt = bfwd->current_alist_element;
+
+ if (!NILP (bfwd->current_buffer) &&
+ current_buffer == XBUFFER (bfwd->current_buffer)
+ && ((some_buffer_local_p)
+ ? 1 /* doesn't automatically become local */
+ : !NILP (aelt) /* already local */
+ ))
{
- CONST struct symbol_value_forward *fwd
- = XSYMBOL_VALUE_FORWARD (valcontents);
- int mask = XINT (*((Lisp_Object *)
- symbol_value_forward_forward (fwd)));
- if (mask > 0)
- /* Setting this variable makes it console-local */
- XCONSOLE (Vselected_console)->local_var_flags |= mask;
- break;
+ /* Cache is valid */
+ valcontents = bfwd->current_value;
}
-
- case SYMVAL_BUFFER_LOCAL:
- case SYMVAL_SOME_BUFFER_LOCAL:
+ else
{
- /* If we want to examine or set the value and
- CURRENT-BUFFER is current, we just examine or set
- CURRENT-VALUE. If CURRENT-BUFFER is not current, we
- store the current CURRENT-VALUE value into
- CURRENT-ALIST- ELEMENT, then find the appropriate alist
- element for the buffer now current and set up
- CURRENT-ALIST-ELEMENT. Then we set CURRENT-VALUE out
- of that element, and store into CURRENT-BUFFER.
-
- If we are setting the variable and the current buffer does
- not have an alist entry for this variable, an alist entry is
- created.
-
- Note that CURRENT-VALUE can be a forwarding pointer.
- Each time it is examined or set, forwarding must be
- done. */
- struct symbol_value_buffer_local *bfwd
- = XSYMBOL_VALUE_BUFFER_LOCAL (valcontents);
- int some_buffer_local_p =
- (bfwd->magic.type == SYMVAL_SOME_BUFFER_LOCAL);
- /* What value are we caching right now? */
- Lisp_Object aelt = bfwd->current_alist_element;
-
- if (!NILP (bfwd->current_buffer) &&
- current_buffer == XBUFFER (bfwd->current_buffer)
- && ((some_buffer_local_p)
- ? 1 /* doesn't automatically become local */
- : !NILP (aelt) /* already local */
- ))
+ /* If the current buffer is not the buffer whose binding is
+ currently cached, or if it's a SYMVAL_BUFFER_LOCAL and
+ we're looking at the default value, the cache is invalid; we
+ need to write it out, and find the new CURRENT-ALIST-ELEMENT
+ */
+
+ /* Write out the cached value for the old buffer; copy it
+ back to its alist element. This works if the current
+ buffer only sees the default value, too. */
+ write_out_buffer_local_cache (symbol, bfwd);
+
+ /* Find the new value for CURRENT-ALIST-ELEMENT. */
+ aelt = buffer_local_alist_element (current_buffer, symbol, bfwd);
+ if (NILP (aelt))
{
- /* Cache is valid */
- valcontents = bfwd->current_value;
- }
- else
- {
- /* If the current buffer is not the buffer whose binding is
- currently cached, or if it's a SYMVAL_BUFFER_LOCAL and
- we're looking at the default value, the cache is invalid; we
- need to write it out, and find the new CURRENT-ALIST-ELEMENT
- */
-
- /* Write out the cached value for the old buffer; copy it
- back to its alist element. This works if the current
- buffer only sees the default value, too. */
- write_out_buffer_local_cache (sym, bfwd);
-
- /* Find the new value for CURRENT-ALIST-ELEMENT. */
- aelt = buffer_local_alist_element (current_buffer, sym, bfwd);
- if (NILP (aelt))
+ /* This buffer is still seeing the default value. */
+ if (!some_buffer_local_p)
+ {
+ /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a
+ new assoc for a local value and set
+ CURRENT-ALIST-ELEMENT to point to that. */
+ aelt =
+ do_symval_forwarding (bfwd->current_value,
+ current_buffer,
+ XCONSOLE (Vselected_console));
+ aelt = Fcons (symbol, aelt);
+ current_buffer->local_var_alist
+ = Fcons (aelt, current_buffer->local_var_alist);
+ }
+ else
{
- /* This buffer is still seeing the default value. */
- if (!some_buffer_local_p)
- {
- /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a
- new assoc for a local value and set
- CURRENT-ALIST-ELEMENT to point to that. */
- aelt =
- do_symval_forwarding (bfwd->current_value,
- current_buffer,
- XCONSOLE (Vselected_console));
- aelt = Fcons (sym, aelt);
- current_buffer->local_var_alist
- = Fcons (aelt, current_buffer->local_var_alist);
- }
- else
- {
- /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL,
- we're currently seeing the default value. */
- ;
- }
+ /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL,
+ we're currently seeing the default value. */
+ ;
}
- /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
- bfwd->current_alist_element = aelt;
- /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
- XSETBUFFER (bfwd->current_buffer, current_buffer);
- valcontents = bfwd->current_value;
}
- break;
+ /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
+ bfwd->current_alist_element = aelt;
+ /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
+ XSETBUFFER (bfwd->current_buffer, current_buffer);
+ valcontents = bfwd->current_value;
}
- default:
- abort ();
- }
+ break;
+ }
+ default:
+ abort ();
}
- store_symval_forwarding (sym, valcontents, newval);
+ store_symval_forwarding (symbol, valcontents, newval);
return newval;
}
XCONSOLE (Vselected_console));
}
- RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */
+ RETURN_NOT_REACHED (Qnil) /* suppress compiler warning */
}
DEFUN ("default-boundp", Fdefault_boundp, 1, 1, 0, /*
This is the value that is seen in buffers that do not have their own values
for this variable.
*/
- (sym))
+ (symbol))
{
- return UNBOUNDP (default_value (sym)) ? Qnil : Qt;
+ return UNBOUNDP (default_value (symbol)) ? Qnil : Qt;
}
DEFUN ("default-value", Fdefault_value, 1, 1, 0, /*
for this variable. The default value is meaningful for variables with
local bindings in certain buffers.
*/
- (sym))
+ (symbol))
{
- Lisp_Object value = default_value (sym);
+ Lisp_Object value = default_value (symbol);
- return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (sym)) : value;
+ return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (symbol)) : value;
}
DEFUN ("set-default", Fset_default, 2, 2, 0, /*
The default value is seen in buffers that do not have their own values
for this variable.
*/
- (sym, value))
+ (symbol, value))
{
Lisp_Object valcontents;
- CHECK_SYMBOL (sym);
+ CHECK_SYMBOL (symbol);
retry:
- valcontents = XSYMBOL (sym)->value;
+ valcontents = XSYMBOL (symbol)->value;
retry_2:
if (!SYMBOL_VALUE_MAGIC_P (valcontents))
- return Fset (sym, value);
+ return Fset (symbol, value);
switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
{
case SYMVAL_LISP_MAGIC:
- RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (sym, Qset_default, 1,
+ RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (symbol, Qset_default, 1,
value));
valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
/* semi-change-o */
goto retry_2;
case SYMVAL_VARALIAS:
- sym = follow_varalias_pointers (sym, Qset_default);
+ symbol = follow_varalias_pointers (symbol, Qset_default);
/* presto change-o! */
goto retry;
case SYMVAL_CURRENT_BUFFER_FORWARD:
- set_default_buffer_slot_variable (sym, value);
+ set_default_buffer_slot_variable (symbol, value);
return value;
case SYMVAL_SELECTED_CONSOLE_FORWARD:
- set_default_console_slot_variable (sym, value);
+ set_default_console_slot_variable (symbol, value);
return value;
case SYMVAL_BUFFER_LOCAL:
/* If current-buffer doesn't shadow default_value,
* we must set the CURRENT-VALUE slot too */
if (NILP (bfwd->current_alist_element))
- store_symval_forwarding (sym, bfwd->current_value, value);
+ store_symval_forwarding (symbol, bfwd->current_value, value);
return value;
}
default:
- return Fset (sym, value);
+ return Fset (symbol, value);
}
- RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */
}
-DEFUN ("setq-default", Fsetq_default, 2, UNEVALLED, 0, /*
-Set the default value of variable SYM to VALUE.
-SYM, the variable name, is literal (not evaluated);
+DEFUN ("setq-default", Fsetq_default, 0, UNEVALLED, 0, /*
+Set the default value of variable SYMBOL to VALUE.
+SYMBOL, the variable name, is literal (not evaluated);
VALUE is an expression and it is evaluated.
The default value of a variable is seen in buffers
that do not have their own values for the variable.
More generally, you can use multiple variables and values, as in
- (setq-default SYM VALUE SYM VALUE...)
-This sets each SYM's default value to the corresponding VALUE.
-The VALUE for the Nth SYM can refer to the new default values
-of previous SYMs.
+ (setq-default SYMBOL VALUE SYMBOL VALUE...)
+This sets each SYMBOL's default value to the corresponding VALUE.
+The VALUE for the Nth SYMBOL can refer to the new default values
+of previous SYMBOLs.
*/
(args))
{
/* This function can GC */
- Lisp_Object args_left;
- Lisp_Object val, sym;
+ Lisp_Object symbol, tail, val = Qnil;
+ int nargs;
struct gcpro gcpro1;
- if (NILP (args))
- return Qnil;
+ GET_LIST_LENGTH (args, nargs);
+
+ if (nargs & 1) /* Odd number of arguments? */
+ Fsignal (Qwrong_number_of_arguments,
+ list2 (Qsetq_default, make_int (nargs)));
- args_left = args;
- GCPRO1 (args);
+ GCPRO1 (val);
- do
+ PROPERTY_LIST_LOOP (tail, symbol, val, args)
{
- val = Feval (Fcar (Fcdr (args_left)));
- sym = Fcar (args_left);
- Fset_default (sym, val);
- args_left = Fcdr (Fcdr (args_left));
+ val = Feval (val);
+ Fset_default (symbol, val);
}
- while (!NILP (args_left));
UNGCPRO;
return val;
Lisp_Object oldval = * (Lisp_Object *)
(offset + (char *) XCONSOLE (Vconsole_defaults));
if (magicfun)
- (magicfun) (variable, &oldval, Vselected_console, 0);
+ magicfun (variable, &oldval, Vselected_console, 0);
*(Lisp_Object *) (offset + (char *) XCONSOLE (Vselected_console))
= oldval;
XCONSOLE (Vselected_console)->local_var_flags &= ~mask;
default:
return variable;
}
- RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */
}
/* Used by specbind to determine what effects it might have. Returns:
CHECK_SYMBOL (symbol);
CHECK_BUFFER (buffer);
value = symbol_value_in_buffer (symbol, buffer);
- if (UNBOUNDP (value))
- return unbound_value;
- else
- return value;
+ return UNBOUNDP (value) ? unbound_value : value;
}
DEFUN ("symbol-value-in-console", Fsymbol_value_in_console, 2, 3, 0, /*
CHECK_SYMBOL (symbol);
CHECK_CONSOLE (console);
value = symbol_value_in_console (symbol, console);
- if (UNBOUNDP (value))
- return unbound_value;
- else
- return value;
+ return UNBOUNDP (value) ? unbound_value : value;
}
DEFUN ("built-in-variable-type", Fbuilt_in_variable_type, 1, 1, 0, /*
-If SYM is a built-in variable, return info about this; else return nil.
+If SYMBOL is a built-in variable, return info about this; else return nil.
The returned info will be a symbol, one of
`object' A simple built-in variable.
`default-console' Forwards to the default value of a built-in
console-local variable.
*/
- (sym))
+ (symbol))
{
REGISTER Lisp_Object valcontents;
- CHECK_SYMBOL (sym);
+ CHECK_SYMBOL (symbol);
retry:
- valcontents = XSYMBOL (sym)->value;
+ valcontents = XSYMBOL (symbol)->value;
+
retry_2:
+ if (!SYMBOL_VALUE_MAGIC_P (valcontents))
+ return Qnil;
- if (SYMBOL_VALUE_MAGIC_P (valcontents))
+ switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
{
- switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents))
- {
- case SYMVAL_LISP_MAGIC:
- valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
- /* semi-change-o */
- goto retry_2;
-
- case SYMVAL_VARALIAS:
- sym = follow_varalias_pointers (sym, Qt);
- /* presto change-o! */
- goto retry;
-
- case SYMVAL_BUFFER_LOCAL:
- case SYMVAL_SOME_BUFFER_LOCAL:
- valcontents =
- XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value;
- /* semi-change-o */
- goto retry_2;
-
- case SYMVAL_FIXNUM_FORWARD:
- return Qinteger;
-
- case SYMVAL_CONST_FIXNUM_FORWARD:
- return Qconst_integer;
-
- case SYMVAL_BOOLEAN_FORWARD:
- return Qboolean;
-
- case SYMVAL_CONST_BOOLEAN_FORWARD:
- return Qconst_boolean;
-
- case SYMVAL_OBJECT_FORWARD:
- return Qobject;
-
- case SYMVAL_CONST_OBJECT_FORWARD:
- return Qconst_object;
-
- case SYMVAL_CONST_SPECIFIER_FORWARD:
- return Qconst_specifier;
-
- case SYMVAL_DEFAULT_BUFFER_FORWARD:
- return Qdefault_buffer;
-
- case SYMVAL_CURRENT_BUFFER_FORWARD:
- return Qcurrent_buffer;
-
- case SYMVAL_CONST_CURRENT_BUFFER_FORWARD:
- return Qconst_current_buffer;
-
- case SYMVAL_DEFAULT_CONSOLE_FORWARD:
- return Qdefault_console;
+ case SYMVAL_LISP_MAGIC:
+ valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed;
+ /* semi-change-o */
+ goto retry_2;
- case SYMVAL_SELECTED_CONSOLE_FORWARD:
- return Qselected_console;
+ case SYMVAL_VARALIAS:
+ symbol = follow_varalias_pointers (symbol, Qt);
+ /* presto change-o! */
+ goto retry;
- case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD:
- return Qconst_selected_console;
+ case SYMVAL_BUFFER_LOCAL:
+ case SYMVAL_SOME_BUFFER_LOCAL:
+ valcontents =
+ XSYMBOL_VALUE_BUFFER_LOCAL (valcontents)->current_value;
+ /* semi-change-o */
+ goto retry_2;
- case SYMVAL_UNBOUND_MARKER:
- return Qnil;
+ case SYMVAL_FIXNUM_FORWARD: return Qinteger;
+ case SYMVAL_CONST_FIXNUM_FORWARD: return Qconst_integer;
+ case SYMVAL_BOOLEAN_FORWARD: return Qboolean;
+ case SYMVAL_CONST_BOOLEAN_FORWARD: return Qconst_boolean;
+ case SYMVAL_OBJECT_FORWARD: return Qobject;
+ case SYMVAL_CONST_OBJECT_FORWARD: return Qconst_object;
+ case SYMVAL_CONST_SPECIFIER_FORWARD: return Qconst_specifier;
+ case SYMVAL_DEFAULT_BUFFER_FORWARD: return Qdefault_buffer;
+ case SYMVAL_CURRENT_BUFFER_FORWARD: return Qcurrent_buffer;
+ case SYMVAL_CONST_CURRENT_BUFFER_FORWARD: return Qconst_current_buffer;
+ case SYMVAL_DEFAULT_CONSOLE_FORWARD: return Qdefault_console;
+ case SYMVAL_SELECTED_CONSOLE_FORWARD: return Qselected_console;
+ case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: return Qconst_selected_console;
+ case SYMVAL_UNBOUND_MARKER: return Qnil;
- default:
- abort ();
- }
+ default:
+ abort (); return Qnil;
}
-
- return Qnil;
}
gets into its final form. I currently like the way everything is
set up and it has all the features I want it to have, except for
one: I really want to be able to have multiple nested handlers,
-to implement an `advice'-like capabiility. This would allow,
+to implement an `advice'-like capability. This would allow,
for example, a clean way of implementing `debug-if-set' or
`debug-if-referenced' and such.
\f
/* functions for working with variable aliases. */
-/* Follow the chain of variable aliases for OBJECT. Return the
+/* Follow the chain of variable aliases for SYMBOL. Return the
resulting symbol, whose value cell is guaranteed not to be a
symbol-value-varalias.
*/
static Lisp_Object
-follow_varalias_pointers (Lisp_Object object,
+follow_varalias_pointers (Lisp_Object symbol,
Lisp_Object follow_past_lisp_magic)
{
- Lisp_Object tortoise = object;
- Lisp_Object hare = object;
+#define VARALIAS_INDIRECTION_SUSPICION_LENGTH 16
+ Lisp_Object tortoise, hare, val;
+ int count;
/* quick out just in case */
- if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (object)->value))
- return object;
-
- /* based off of indirect_function() */
- for (;;)
+ if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (symbol)->value))
+ return symbol;
+
+ /* Compare implementation of indirect_function(). */
+ for (hare = tortoise = symbol, count = 0;
+ val = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic),
+ SYMBOL_VALUE_VARALIAS_P (val);
+ hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (val)),
+ count++)
{
- Lisp_Object value;
-
- value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic);
- if (!SYMBOL_VALUE_VARALIAS_P (value))
- break;
- hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value));
- value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic);
- if (!SYMBOL_VALUE_VARALIAS_P (value))
- break;
- hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value));
-
- value = fetch_value_maybe_past_magic (tortoise, follow_past_lisp_magic);
- tortoise = symbol_value_varalias_aliasee
- (XSYMBOL_VALUE_VARALIAS (value));
+ if (count < VARALIAS_INDIRECTION_SUSPICION_LENGTH) continue;
+ if (count & 1)
+ tortoise = symbol_value_varalias_aliasee
+ (XSYMBOL_VALUE_VARALIAS (fetch_value_maybe_past_magic
+ (tortoise, follow_past_lisp_magic)));
if (EQ (hare, tortoise))
- return Fsignal (Qcyclic_variable_indirection, list1 (object));
+ return Fsignal (Qcyclic_variable_indirection, list1 (symbol));
}
return hare;
#ifndef Qnull_pointer
/* C guarantees that Qnull_pointer will be initialized to all 0 bits,
- so the following is a actually a no-op. */
+ so the following is actually a no-op. */
XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0);
#endif
/* see comment in Fpurecopy() */
Vpure_uninterned_symbol_table =
- make_lisp_hashtable (50, HASHTABLE_NONWEAK, HASHTABLE_EQ);
+ make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ);
staticpro (&Vpure_uninterned_symbol_table);
Qnil = Fmake_symbol (make_pure_pname ((CONST Bufbyte *) "nil", 3, 1));
Fset (*location, *location);
}
-void
-defsubr (struct Lisp_Subr *subr)
-{
- Lisp_Object sym = intern (subr_name (subr));
-
#ifdef DEBUG_XEMACS
- /* Check that nobody spazzed writing a DEFUN. */
+/* Check that nobody spazzed writing a DEFUN. */
+static void
+check_sane_subr (Lisp_Subr *subr, Lisp_Object sym)
+{
assert (subr->min_args >= 0);
assert (subr->min_args <= SUBR_MAX_ARGS);
- if (subr->max_args != MANY && subr->max_args != UNEVALLED)
+ if (subr->max_args != MANY &&
+ subr->max_args != UNEVALLED)
{
/* Need to fix lisp.h and eval.c if SUBR_MAX_ARGS too small */
assert (subr->max_args <= SUBR_MAX_ARGS);
}
assert (UNBOUNDP (XSYMBOL (sym)->function));
-#endif /* DEBUG_XEMACS */
+}
+#else
+#define check_sane_subr(subr, sym) /* nothing */
+#endif
+
+void
+defsubr (Lisp_Subr *subr)
+{
+ Lisp_Object sym = intern (subr_name (subr));
+ Lisp_Object fun;
+
+ check_sane_subr (subr, sym);
+
+ XSETSUBR (fun, subr);
+ XSYMBOL (sym)->function = fun;
+}
+
+/* Define a lisp macro using a Lisp_Subr. */
+void
+defsubr_macro (Lisp_Subr *subr)
+{
+ Lisp_Object sym = intern (subr_name (subr));
+ Lisp_Object fun;
+
+ check_sane_subr (subr, sym);
- XSETSUBR (XSYMBOL (sym)->function, subr);
+ XSETSUBR (fun, subr);
+ XSYMBOL (sym)->function = Fcons (Qmacro, fun);
}
void
defsymbol (&Qmakunbound, "makunbound");
defsymbol (&Qsymbol_value, "symbol-value");
defsymbol (&Qset, "set");
+ defsymbol (&Qsetq_default, "setq-default");
defsymbol (&Qdefault_boundp, "default-boundp");
defsymbol (&Qdefault_value, "default-value");
defsymbol (&Qset_default, "set-default");
DEFSUBR (Ffboundp);
DEFSUBR (Ffset);
DEFSUBR (Fdefine_function);
+ Ffset (intern ("defalias"), intern ("define-function"));
DEFSUBR (Fsetplist);
DEFSUBR (Fsymbol_value_in_buffer);
DEFSUBR (Fsymbol_value_in_console);
DEFSUBR (Fdontusethis_set_symbol_value_handler);
}
-/* Create and initialize a variable whose value is forwarded to C data */
+/* Create and initialize a Lisp variable whose value is forwarded to C data */
void
-defvar_mumble (CONST char *namestring, CONST void *magic, size_t sizeof_magic)
+defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic)
{
- Lisp_Object kludge;
- Lisp_Object sym = Fintern (make_pure_pname ((CONST Bufbyte *) namestring,
- strlen (namestring),
- 1),
- Qnil);
+ Lisp_Object sym, kludge;
- /* Check that magic points somewhere we can represent as a Lisp pointer */
+ /* Check that `magic' points somewhere we can represent as a Lisp pointer */
XSETOBJ (kludge, Lisp_Type_Record, magic);
- if (magic != (CONST void *) XPNTR (kludge))
+ if ((void *)magic != (void*) XPNTR (kludge))
{
/* This might happen on DATA_SEG_BITS machines. */
/* abort (); */
/* Copy it to somewhere which is representable. */
- void *f = xmalloc (sizeof_magic);
- memcpy (f, magic, sizeof_magic);
- XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, f);
+ struct symbol_value_forward *p = xnew (struct symbol_value_forward);
+ memcpy (p, magic, sizeof *magic);
+ magic = p;
}
- else
- XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic);
+
+ sym = Fintern (make_pure_pname ((CONST Bufbyte *) symbol_name,
+ strlen (symbol_name),
+ 1),
+ Qnil);
+ XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic);
}
void
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_ */
void structure_type_create_chartab (void);
void structure_type_create_faces (void);
void structure_type_create_rangetab (void);
-void structure_type_create_hashtable (void);
+void structure_type_create_hash_table (void);
/* Initialize the image instantiator types (dump-time only). */
#include "lisp.h"
#include "buffer.h"
-#include "commands.h"
-#include "insdel.h"
#include "syntax.h"
/* Here is a comment from Ken'ichi HANDA <handa@etl.go.jp>
}
DEFUN ("forward-word", Fforward_word, 1, 2, "_p", /*
-Move point forward ARG words (backward if ARG is negative).
+Move point forward COUNT words (backward if COUNT is negative).
Normally returns t.
If an edge of the buffer is reached, point is left there
and nil is returned.
+
+Optional argument BUFFER defaults to the current buffer.
*/
(count, buffer))
{
INLINE int
WORD_SYNTAX_P (struct Lisp_Char_Table *table, Emchar c)
{
- int syncode = SYNTAX (table, c);
- return syncode == Sword;
+ return SYNTAX (table, c) == Sword;
}
/* OK, here's a graphic diagram of the format of the syntax values:
}
#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;
#include "console-x.h"
#include "glyphs-x.h"
#include "objects-x.h"
-#include "xgccache.h"
#include "EmacsFrame.h"
#include "EmacsFrameP.h"
-#include "EmacsManager.h"
#include "faces.h"
#include "frame.h"
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
projects / chise / xemacs-chise.git.1 / commitdiff