# HG changeset patch # User cvs # Date 1186996030 -7200 # Node ID 8626e45219933e074ee93d11b87d9ae9581e4efa # Parent 76b7d63099ad94f645b2dd0fccf5262b5997f1a9 Import from CVS: tag r21-2-5 diff -r 76b7d63099ad -r 8626e4521993 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 11:06:08 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 11:07:10 2007 +0200 @@ -1,4 +1,16 @@ -*- indented-text -*- +to 21.2 beta5 "Aphrodite" +-- bytecode interpreter rewritten +-- byte compiler fixes +-- hash table implementation rewritten +-- basic lisp functions rewritten +-- spelling fixes +-- garbage collector tuned a little +-- various global code changes for consistency +-- automated test suite +-- major internals manual updates +-- lisp reference updates + to 21.2 beta4 "Aglaophonos" -- isearch keymap fix from Katsumi Yamaoka -- directory_files cleanup from Hrvoje Niksic diff -r 76b7d63099ad -r 8626e4521993 ChangeLog --- a/ChangeLog Mon Aug 13 11:06:08 2007 +0200 +++ b/ChangeLog Mon Aug 13 11:07:10 2007 +0200 @@ -1,3 +1,7 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff -r 76b7d63099ad -r 8626e4521993 INSTALL --- a/INSTALL Mon Aug 13 11:06:08 2007 +0200 +++ b/INSTALL Mon Aug 13 11:07:10 2007 +0200 @@ -157,11 +157,6 @@ variable CFLAGS is consulted. If that is also undefined, CFLAGS defaults to "-g -O" for gcc and "-g" for all other compilers. -The `--with-gnu-make' option specifies that Makefiles should be -written to take advantage of special features of GNU Make. GNU Make -works fine on Makefiles even without this option. This flag just -allows for simultaneous in-place and --srcdir building. - The `--dynamic' option specifies that configure should try to link emacs dynamically rather than statically. @@ -500,6 +495,9 @@ the command. See the section below called `MAKE VARIABLES' for more information on this. +Using GNU Make allows for simultaneous builds with and without the +--srcdir option. + 8) If your system uses lock files to interlock access to mailer inbox files, then you might need to make the movemail program setuid or setgid to enable it to write the lock files. We believe this is safe. diff -r 76b7d63099ad -r 8626e4521993 Makefile.in --- a/Makefile.in Mon Aug 13 11:06:08 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,632 +0,0 @@ -## DIST: This is the distribution Makefile for XEmacs. configure can -## DIST: make most of the changes to this file you might want, so try -## DIST: that first. - -## 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. - -## make all to compile and build XEmacs. -## make install to build and install it. -## make install-only to install after a previous complete build -## make TAGS to update tags tables. - -## make clean or make mostlyclean -## Delete all files from the current directory that are normally -## created by building the program. Don't delete the files that -## record the configuration. Also preserve files that could be made -## by building, but normally aren't because the distribution comes -## with them. - -## Delete `.dvi' files here if they are not part of the distribution. - -## make distclean -## Delete all files from the current directory that are created by -## configuring or building the program. If you have unpacked the -## source and built the program without creating any other files, -## `make distclean' should leave only the files that were in the -## distribution. - -## make realclean -## Delete everything from the current directory that can be -## reconstructed with this Makefile. This typically includes -## everything deleted by distclean, plus more: C source files -## produced by Bison, tags tables, info files, and so on. - -## make extraclean -## Still more severe - delete backup and autosave files, too. - -@SET_MAKE@ -RECURSIVE_MAKE=@RECURSIVE_MAKE@ -SHELL = /bin/sh -LANG = C -RM = rm -f -pwd = /bin/pwd - -## ==================== Things `configure' Might Edit ==================== - -CC=@CC@ -CPP=@CPP@ -LN_S=@LN_S@ -CFLAGS=@CFLAGS@ -CPPFLAGS=@CPPFLAGS@ -LDFLAGS=@LDFLAGS@ - -## These help us choose version- and architecture-specific directories -## to install files in. - -## This should be the number of the XEmacs version we're building, -## like `19.12' or `19.13'. -version=@version@ - -## This should be the name of the configuration we're building XEmacs -## for, like `mips-dec-ultrix' or `sparc-sun-sunos'. -configuration=@configuration@ - -## This will be the name of the generated binary and is set automatically -## by configure. -PROGNAME=@PROGNAME@ - -## ==================== Where To Install Things ==================== - -## The default location for installation. Everything is placed in -## subdirectories of this directory. The default values for many of -## the variables below are expressed in terms of this one, so you may -## not need to change them. This defaults to /usr/local. -prefix=@prefix@ - -## Like `prefix', but used for architecture-specific files. -exec_prefix=@exec_prefix@ - -## Where to install XEmacs and other binaries that people will want to -## run directly (like etags). -bindir=@bindir@ - -## Where to install architecture-independent data files. -## ${lispdir} and ${etcdir} are subdirectories of this. -datadir=@datadir@ - -## Where to find XEmacs packages. -pkgdir=@pkgdir@ - -## Where to install and expect the files that XEmacs modifies as it runs. -## These files are all architecture-independent. Right now, the -## only such data is the locking directory; -## ${lockdir} is a subdirectory of this. -statedir=@statedir@ - -## Where to install and expect executable files to be run by XEmacs -## rather than directly by users, and other architecture-dependent data -## ${archlibdir} is a subdirectory of this. -libdir=@libdir@ - -## Where to install XEmacs's man pages, and what extension they should have. -mandir=@mandir@ -manext=.1 - -## Where to install and expect the info files describing XEmacs. In the -## past, this defaulted to a subdirectory of ${prefix}/lib/xemacs, but -## since there are now many packages documented with the texinfo -## system, it is inappropriate to imply that it is part of XEmacs. -infodir=@infodir@ - -## Document me. -## See callproc.c for code which references this. -infopath=@infopath@ - -## Where to find the source code. The source code for XEmacs's C kernel is -## expected to be in ${srcdir}/src, and the source code for XEmacs's -## utility programs is expected to be in ${srcdir}/lib-src. This is -## set by the configure script's `--srcdir' option. -srcdir=@srcdir@ - -## Where the build is done. -blddir=@blddir@ - -## ==================== XEmacs-specific directories ==================== - -## These variables hold the values XEmacs will actually use. They are -## based on the values of the standard Make variables above. - -## Where to install the lisp files distributed with -## XEmacs. This includes the XEmacs version, so that the -## lisp files for different versions of XEmacs will install -## themselves in separate directories. -lispdir=@lispdir@ - -## Directory XEmacs should search for lisp files specific -## to this site (i.e. customizations), before consulting -## ${lispdir}. -sitelispdir=@sitelispdir@ - -## Where XEmacs will search for its lisp files while -## building. This is only used during the process of -## compiling XEmacs, to help XEmacs find its lisp files -## before they've been installed in their final location. -## It's usually identical to lispdir, except that the -## entry for the directory containing the installed lisp -## files has been replaced with ../lisp. This should be a -## colon-separated list of directories. -buildlispdir=${srcdir}/lisp - -## Where to install the other architecture-independent -## data files distributed with XEmacs (like the tutorial, -## the cookie recipes and the Zippy database). This path -## usually contains the XEmacs version number, so the data -## files for multiple versions of XEmacs may be installed -## at once. -etcdir=@etcdir@ - -## Where to create and expect the locking directory, where -## the XEmacs locking code keeps track of which files are -## currently being edited. -lockdir=@lockdir@ - -## Where to put executables to be run by XEmacs rather than -## the user. This path usually includes the XEmacs version -## and configuration name, so that multiple configurations -## for multiple versions of XEmacs may be installed at -## once. -archlibdir=@archlibdir@ - -## ==================== Utility Programs for the Build ==================== - -## Allow the user to specify the install program. -INSTALL = @install_pp@ @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ - -## ============================= Targets ============================== - -## Subdirectories to make recursively. `lisp' is not included -## because the compiled lisp files are part of the distribution -## and you cannot remake them without installing XEmacs first. -MAKE_SUBDIR = @MAKE_SUBDIR@ - -## Subdirectories that can be made recursively. -SUBDIR = ${MAKE_SUBDIR} man - -## The makefiles of the directories in ${MAKE_SUBDIR}. -SUBDIR_MAKEFILES = @SUBDIR_MAKEFILES@ - -## Subdirectories to `make install-arch-dep' recursively -INSTALL_ARCH_DEP_SUBDIR = @INSTALL_ARCH_DEP_SUBDIR@ - -## Subdirectories to install, and where they'll go. -## lib-src's makefile knows how to install it, so we don't do that here. -## When installing the info files, we need to do special things to -## avoid nuking an existing dir file, so we don't do that here; -## instead, we have written out explicit code in the `install' targets. -COPYDIR = ${srcdir}/etc ${srcdir}/lisp -COPYDESTS = ${etcdir} ${lispdir} -GENERATED_HEADERS = src/paths.h src/Emacs.ad.h src/puresize-adjust.h src/config.h lwlib/config.h src/sheap-adjust.h -GENERATED_LISP = lisp/finder-inf.el - -all: ${PROGNAME} all-elc info - -${PROGNAME}: ${GENERATED_HEADERS} ${MAKE_SUBDIR} ${GENERATED_LISP} - -## For performance and consistency, no built-in rules -.SUFFIXES: - -.NO_PARALLEL: ${GENERATED_HEADERS} ${MAKE_SUBDIR} dump-elcs -.PHONY: ${SUBDIR} all beta all-elc all-elcs dump-elc dump-elcs autoloads finder - -## Convenience target for XEmacs beta testers -beta: clean all-elc finder - -## Convenience target for XEmacs maintainers -## This would run `make-xemacsdist' if I were really confident that everything -## was turnkey. -dist: all-elc info - -## Convenience target for XEmacs maintainers -## Updates some rarely generated files: -## - configure from configure.in -## - config.values.in from configure -## - src/depend from src/*.[ch] -.PHONY: config configure depend -config: configure depend -configure: ${srcdir}/configure -${srcdir}/configure: ${srcdir}/configure.in - cd ${srcdir} && autoconf - cd ${srcdir} && /bin/sh lib-src/config.values.sh - -depend ${srcdir}/src/depend: - cd ${srcdir}/src && \ - perl ./make-src-depend > depend.tmp && \ - $(RM) depend && mv depend.tmp depend - -## Build XEmacs and recompile out-of-date and missing .elc files along -## the way. -all-elc all-elcs: lib-src lwlib dump-elcs src - MAKE='$(MAKE)' EMACS='./src/$(PROGNAME)' sh ${srcdir}/lib-src/update-elc.sh - -## Sub-target for all-elc. -dump-elc dump-elcs: ${GENERATED_HEADERS} FRC.dump-elcs - cd ./src && $(RECURSIVE_MAKE) dump-elcs - -autoloads: src - MAKE='$(MAKE)' EMACS='./src/$(PROGNAME)' sh ${srcdir}/lib-src/update-autoloads.sh - -custom-loads: - MAKE='$(MAKE)' EMACS='./src/$(PROGNAME)' sh ${srcdir}/lib-src/update-custom.sh - -finder: src - @echo "Building finder database ..." - @(cd ./lisp; \ - ${blddir}/src/${PROGNAME} -batch -vanilla \ - -eval '(setq finder-compile-keywords-quiet t)' \ - -l finder -f finder-compile-keywords ) - @echo "Building finder database ...(done)" - -lisp/finder-inf.el: - @echo "Building finder database ..." - @(cd ./lisp; \ - ${blddir}/src/${PROGNAME} -batch -vanilla \ - -eval '(setq finder-compile-keywords-quiet t)' \ - -l finder -f finder-compile-keywords ) - @echo "Building finder database ...(done)" - -## We have to force the building of Emacs.ad.h as well in order to get it -## updated correctly when VPATH is being used. Since we use move-if-change, -## it will only actually change if the user modified ${etcdir}/Emacs.ad. -src/Emacs.ad.h: ${srcdir}/etc/Emacs.ad - @echo "Producing \`src/Emacs.ad.h' from \`etc/Emacs.ad'." - @$(RM) src/Emacs.ad.h - @(echo "/* Do not edit this file!" ; \ - echo " Automatically generated from ${srcdir}/etc/Emacs.ad" ; \ - echo " */" ; \ - /bin/sh ${srcdir}/lib-src/ad2c ${srcdir}/etc/Emacs.ad ) > \ - src/Emacs.ad.h - -src/puresize-adjust.h: ${srcdir}/src/puresize.h - @echo "Resetting \`src/puresize-adjust.h'."; \ - (echo "/* Do not edit this file!" ; \ - echo " Automatically generated by XEmacs */" ; \ - echo "#define PURESIZE_ADJUSTMENT 0") > $@ - -src/sheap-adjust.h: - @echo "Resetting \`src/sheap-adjust.h'."; \ - (echo "/* Do not edit this file!" ; \ - echo " Automatically generated by XEmacs */" ; \ - echo "#define SHEAP_ADJUSTMENT 0") > $@ - -src: @SRC_SUBDIR_DEPS@ FRC.src -pkg-src/tree-x: pkg-src/FRC.tree-x -lib-src: FRC.lib-src -lwlib: FRC.lwlib -dynodump: FRC.dynodump -FRC.src FRC.lib-src FRC.lwlib FRC.dynodump pkg-src/FRC.tree-x: -FRC.lisp.finder-inf.el: - -${SUBDIR}: ${SUBDIR_MAKEFILES} ${GENERATED_HEADERS} FRC - cd ./$@ && $(RECURSIVE_MAKE) all - -Makefile: ${srcdir}/Makefile.in config.status - ./config.status - -src/Makefile: ${srcdir}/src/Makefile.in.in ${srcdir}/src/depend config.status - ./config.status - -lib-src/Makefile: ${srcdir}/lib-src/Makefile.in.in config.status - ./config.status - -lwlib/Makefile: ${srcdir}/lwlib/Makefile.in.in config.status - ./config.status - -pkg-src/tree-x/Makefile: ${srcdir}/pkg-src/tree-x/Makefile.in.in config.status - ./config.status - -src/config.h: ${srcdir}/src/config.h.in - ./config.status && touch $@ - -src/paths.h: ${srcdir}/src/paths.h.in - ./config.status && touch $@ - -lwlib/config.h: ${srcdir}/lwlib/config.h.in - ./config.status && touch $@ - -## ==================== Installation ==================== - -## If we let lib-src do its own installation, that means we -## don't have to duplicate the list of utilities to install in -## this Makefile as well. - -## On AIX, use tar xBf. -## On Xenix, use tar xpf. - -.PHONY: install-only install install-arch-dep install-arch-indep gzip.el mkdir -.PHONY: check-features - -## We delete each directory in ${COPYDESTS} before we copy into it; -## that way, we can reinstall over directories that have been put in -## place with their files read-only (perhaps because they are checked -## into RCS). In order to make this safe, we make sure that the -## source exists and is distinct from the destination. - -## FSF doesn't depend on `all', but rather on ${MAKE_SUBDIR}, so that -## they "won't ever modify src/paths.h". But that means you can't do -## 'make install' right off the bat because src/paths.h won't exist. -## And, in XEmacs case, src/Emacs.ad.h won't exist either. I also -## don't see the point in avoiding modifying paths.h. It creates an -## inconsistency in the build process. So we go ahead and depend on -## all. --cet - -check-features: all - ${blddir}/src/${PROGNAME} -batch -l check-features.el - -install-only: ${MAKE_SUBDIR} check-features install-arch-dep install-arch-indep - -install: all check-features install-arch-dep install-arch-indep - -install-arch-dep: mkdir - for subdir in ${INSTALL_ARCH_DEP_SUBDIR}; do \ - (cd ./$${subdir} && $(RECURSIVE_MAKE) install prefix=${prefix} \ - exec_prefix=${exec_prefix} bindir=${bindir} libdir=${libdir} \ - archlibdir=${archlibdir}) ; done - if test "`(cd ${archlibdir} && $(pwd))`" != \ - "`(cd ./lib-src && $(pwd))`"; then \ - if test -f ../Installation; then \ - ${INSTALL_DATA} ../Installation ${archlibdir}/Installation; \ - fi; \ - for f in DOC config.values; do \ - ${INSTALL_DATA} lib-src/$${f} ${archlibdir}/$${f}; \ - done ; \ - for subdir in `find ${archlibdir} -type d ! -name RCS ! -name SCCS ! -name CVS -print` ; \ - do (cd $${subdir} && $(RM) -r RCS CVS SCCS \#* *~) ; done ; \ - else true; fi - ${INSTALL_PROGRAM} src/${PROGNAME} ${bindir}/${PROGNAME}-${version} - -chmod 0755 ${bindir}/${PROGNAME}-${version} - cd ${bindir} && $(RM) ./${PROGNAME} && ${LN_S} ${PROGNAME}-${version} ./${PROGNAME} - if test "${prefix}" != "${exec_prefix}"; then \ - for dir in \ - lib/${PROGNAME} \ - lib/${PROGNAME}-${version}/etc \ - lib/${PROGNAME}-${version}/info \ - lib/${PROGNAME}-${version}/lisp; do \ - if test ! -d ${exec_prefix}/$${dir}; then \ - $(LN_S) ${prefix}/$${dir} ${exec_prefix}/$${dir}; fi; \ - done; \ - fi - -install-arch-indep: mkdir info - -@set ${COPYDESTS} ; \ - for dir in ${COPYDIR} ; do \ - if test "`(cd $$1 && $(pwd))`" != \ - "`(cd $${dir} && $(pwd))`"; then \ - : do nothing - echo "rm -rf $$1" ; \ - fi ; \ - shift ; \ - done - -set ${COPYDESTS} ; \ - for dir in ${COPYDESTS} ; do \ - if test ! -d $${dir} ; then mkdir $${dir} ; fi ; \ - done ; \ - for dir in ${COPYDIR} ; do \ - dest=$$1 ; shift ; \ - test -d $${dir} \ - -a "`(cd $${dir} && $(pwd))`" != \ - "`(cd $${dest} && $(pwd))`" \ - && (echo "Copying $${dir}..." ; \ - (cd $${dir} && tar -cf - . ) | \ - (cd $${dest} && umask 022 && tar -xf - );\ - chmod 0755 $${dest}; \ - for subdir in `find $${dest} -type d ! -name RCS ! -name SCCS ! -name CVS -print` ; do \ - (cd $${subdir} && $(RM) -r RCS CVS SCCS \#* *~) ; \ - done) ; \ - done - if test "`(cd ${srcdir}/info && $(pwd))`" != \ - "`(cd ${infodir} && $(pwd))`" && cd ${srcdir}/info; then \ - if test ! -f ${infodir}/dir -a -f dir ; then \ - ${INSTALL_DATA} ${srcdir}/info/dir ${infodir}/dir ; \ - fi ; \ - for file in *.info* ; do \ - ${INSTALL_DATA} $${file} ${infodir}/$${file} ; \ - chmod 0644 ${infodir}/$${file}; \ - done ; \ - fi - ## Note it's `xemacs' not ${PROGNAME} - cd ${srcdir}/etc && \ - for page in xemacs etags ctags gnuserv gnuclient gnuattach gnudoit; do \ - ${INSTALL_DATA} ${srcdir}/etc/$${page}.1 ${mandir}/$${page}${manext} ; \ - chmod 0644 ${mandir}/$${page}${manext} ; \ - done - @echo "If you would like to save approximately 2M of disk space, do" - @echo "make gzip-el" - @echo "or you may run " - @echo ${srcdir}/lib-src/gzip-el.sh lispdir " from the command line." - @echo "Where lispdir is where the lisp files were installed, i.e.," - @echo "${lispdir}" - -gzip-el: - ${srcdir}/lib-src/gzip-el.sh ${lispdir} - -MAKEPATH=./lib-src/make-path -## Build all the directories to install XEmacs in. -## Since we may be creating several layers of directories, -## (e.g. /usr/local/lib/${PROGNAME}-20.5/sparc-sun-solaris2.6), we use -## make-path instead of mkdir. Not all mkdirs have the `-p' flag. -mkdir: FRC.mkdir - ${MAKEPATH} ${COPYDESTS} ${lockdir} ${infodir} ${archlibdir} \ - ${mandir} ${bindir} ${datadir} ${libdir} ${pkgdir} - -chmod 0777 ${lockdir} - -## Delete all the installed files that the `install' target would -## create (but not the noninstalled files such as `make all' would -## create). - -#### Don't delete the lisp and etc directories if they're in the source tree. -#### This target has not been updated in sometime and until it is it -#### would be extremely dangerous for anyone to use it. -#uninstall: -# (cd ./lib-src; \ -# $(RECURSIVE_MAKE) uninstall \ -# prefix=${prefix} exec_prefix=${exec_prefix} \ -# bindir=${bindir} libdir=${libdir} archlibdir=${archlibdir}) -# for dir in ${lispdir} ${etcdir} ; do \ -# case `(cd $${dir} ; $(pwd))` in \ -# `(cd ${srcdir} ; $(pwd))`* ) ;; \ -# * ) $(RM) $${dir} ;; \ -# esac ; \ -# case $${dir} in \ -# ${datadir}/${PROGNAME}/${version}/* ) \ -# $(RM) -r ${datadir}/${PROGNAME}/${version} \ -# ;; \ -# esac ; \ -# done -# cd ${infodir} && $(RM) cl* ${PROGNAME}* forms* info* vip* -# cd ${mandir} && $(RM) xemacs.1 etags.1 ctags.1 gnuserv.1 -# cd ${bindir} && $(RM) ${PROGNAME}-${version} ${PROGNAME} - - -## Some makes seem to remember that they've built something called FRC, -## so you can only use a given FRC once per makefile. -FRC FRC.src.paths.h FRC.mkdir FRC.dump-elcs FRC.info: -FRC.mostlyclean FRC.clean FRC.distclean FRC.realclean FRC.tags: - -## ==================== Cleaning up and miscellanea ==================== - -.PHONY: mostlyclean clean distclean realclean extraclean - -## `mostlyclean' -## Like `clean', but may refrain from deleting a few files that people -## normally don't want to recompile. For example, the `mostlyclean' -## target for GCC does not delete `libgcc.a', because recompiling it -## is rarely necessary and takes a lot of time. -mostlyclean: FRC.mostlyclean - for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - -## `clean' -## Delete all files from the current directory that are normally -## created by building the program. Don't delete the files that -## record the configuration. Also preserve files that could be made -## by building, but normally aren't because the distribution comes -## with them. - -## Delete `.dvi' files here if they are not part of the distribution. -clean: FRC.clean - for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - $(RM) core - -## `distclean' -## Delete all files from the current directory that are created by -## configuring or building the program. If you have unpacked the -## source and built the program without creating any other files, -## `make distclean' should leave only the files that were in the -## distribution. -top_distclean=\ - $(RM) config.status config.log config-tmp-* build-install Installation ; \ - for d in src lib-src lwlib dynodump ; do \ - $(RM) $$d/Makefile $$d/Makefile.in ; \ - done ; \ - $(RM) core .sbinit Makefile lock/*; \ - $(RM) lisp/finder-inf.el* Installation.el Installation.elc; \ - $(RM) packages mule-packages site-lisp - -distclean: FRC.distclean - for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - -${top_distclean} - -## `realclean' -## Delete everything from the current directory that can be -## reconstructed with this Makefile. This typically includes -## everything deleted by distclean, plus more: C source files -## produced by Bison, tags tables, info files, and so on. - -## One exception, however: `make realclean' should not delete -## `configure' even if `configure' can be remade using a rule in the -## Makefile. More generally, `make realclean' should not delete -## anything that needs to exist in order to run `configure' and then -## begin to build the program. -realclean: FRC.realclean - for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - -${top_distclean} - $(RM) TAGS - -## This doesn't actually appear in the coding standards, but Karl -## says GCC supports it, and that's where the configuration part of -## the coding standards seem to come from. It's like distclean, but -## it deletes backup and autosave files too. -extraclean: - for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - $(RM) *~ \#* - -${top_distclean} - -## Unlocking and relocking. The idea of these productions is to reduce -## hassles when installing an incremental tar of XEmacs. Do `make unlock' -## before unlocking the file to take the write locks off all sources so -## that tar xvof will overwrite them without fuss. Then do `make relock' -## afterward so that VC mode will know which files should be checked in -## if you want to mung them. - -## Note: it's no disaster if these productions miss a file or two; tar -## and VC will swiftly let you know if this happens, and it is easily -## corrected. -SOURCES = ChangeLog GETTING.GNU.SOFTWARE INSTALL Makefile.in PROBLEMS \ - README build-install.in configure make-dist move-if-change - -.PHONY: unlock relock TAGS tags check dist info dvi mcs - -unlock: - chmod u+w $(SOURCES) cpp/* - -cd ./elisp && chmod u+w Makefile README *.texi - for d in src etc lib-src lisp; do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - cd ./lisp/term && chmod u+w README *.el - cd ./man && chmod u+w *texi* ChangeLog split-man - cd ./lwlib && chmod u+w *.[ch] Makefile.in.in - -relock: - chmod u-w $(SOURCES) cpp/* - -cd ./elisp && chmod u-w Makefile README *.texi - for d in src etc lib-src lisp; do (cd ./$$d && $(RECURSIVE_MAKE) $@); done - cd ./lisp/term && chmod u+w README *.el - cd ./man && chmod u+w *texi* ChangeLog split-man - cd ./lwlib && chmod u+w *.[ch] Makefile.in.in - -PRUNE_VC = -name SCCS -prune -o -name RCS -prune -o -name CVS -prune -o -tagslisp = lisp -TAGS tags: FRC.tags - @echo "If you don't have a copy of etags around, then do 'make lib-src' first." - $(RM) ${srcdir}/TAGS - @PATH=`$(pwd)`/lib-src:$$PATH HOME=/-=-; export PATH HOME; \ - echo "Using etags from `which etags`." - PATH=`$(pwd)`/lib-src:$$PATH ; export PATH; cd ${srcdir} && \ - find src lwlib lib-src ${PRUNE_VC} -name '*.[ch]' -print | \ - xargs etags -a -r '/[ ]*DEF\(VAR\|INE\)_[A-Z_]+[ ]*([ ]*"\([^"]+\)"/\2/'; \ - find ${tagslisp} ${PRUNE_VC} -name '*.el' -print | \ - xargs etags -a -l none -r "/^(def\\(var\\|un\\|alias\\|const\\|macro\\)[ ]+'?\\([^ ]+\\)/\\2/" - -## We have automated tests! -testdir = ${srcdir}/tests -tests = ${testdir}/basic-lisp.el ${testdir}/database.el - -check: - src/${PROGNAME} -batch -l ${testdir}/test-emacs.el -f batch-test-emacs ${tests} - -info: FRC.info - cd ${srcdir}/man && $(RECURSIVE_MAKE) $@ - -dvi: - cd ${srcdir}/man && $(RECURSIVE_MAKE) $@ - -## Fix up version information in executables (Solaris-only) -mcs: - date=`LANG=C LC_ALL=C date -u '+%e %b %Y'`; \ - ident="@(#)RELEASE VERSION XEmacs ${version} $${date}"; \ - for f in `file lib-src/* src/${PROGNAME} | grep ELF | sed -e 's/:.*//'`; do \ - mcs -da "$${ident} `echo $${f} | sed 's/.*\///'`" $${f}; \ - done diff -r 76b7d63099ad -r 8626e4521993 Makefile.in.in --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile.in.in Mon Aug 13 11:07:10 2007 +0200 @@ -0,0 +1,632 @@ +## DIST: This is the distribution Makefile for XEmacs. configure can +## DIST: make most of the changes to this file you might want, so try +## DIST: that first. + +## 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. + +## make all to compile and build XEmacs. +## make install to build and install it. +## make install-only to install after a previous complete build +## make TAGS to update tags tables. + +## make clean or make mostlyclean +## Delete all files from the current directory that are normally +## created by building the program. Don't delete the files that +## record the configuration. Also preserve files that could be made +## by building, but normally aren't because the distribution comes +## with them. + +## Delete `.dvi' files here if they are not part of the distribution. + +## make distclean +## Delete all files from the current directory that are created by +## configuring or building the program. If you have unpacked the +## source and built the program without creating any other files, +## `make distclean' should leave only the files that were in the +## distribution. + +## make realclean +## Delete everything from the current directory that can be +## reconstructed with this Makefile. This typically includes +## everything deleted by distclean, plus more: C source files +## produced by Bison, tags tables, info files, and so on. + +## make extraclean +## Still more severe - delete backup and autosave files, too. + +#ifdef USE_GNU_MAKE +RECURSIVE_MAKE=$(MAKE) +#else +@SET_MAKE@ +RECURSIVE_MAKE=@RECURSIVE_MAKE@ +#endif + +SHELL = /bin/sh +LANG = C +RM = rm -f +pwd = /bin/pwd + +## ==================== Things `configure' Might Edit ==================== + +CC=@CC@ +CPP=@CPP@ +LN_S=@LN_S@ +CFLAGS=@CFLAGS@ +CPPFLAGS=@CPPFLAGS@ + +## These help us choose version- and architecture-specific directories +## to install files in. + +## This should be the number of the XEmacs version we're building, +## like `19.12' or `19.13'. +version=@version@ + +## This should be the name of the configuration we're building XEmacs +## for, like `mips-dec-ultrix' or `sparc-sun-sunos'. +configuration=@configuration@ + +## This will be the name of the generated binary and is set automatically +## by configure. +PROGNAME=@PROGNAME@ + +## ==================== Where To Install Things ==================== + +## The default location for installation. Everything is placed in +## subdirectories of this directory. The default values for many of +## the variables below are expressed in terms of this one, so you may +## not need to change them. This defaults to /usr/local. +prefix=@prefix@ + +## Like `prefix', but used for architecture-specific files. +exec_prefix=@exec_prefix@ + +## Where to install XEmacs and other binaries that people will want to +## run directly (like etags). +bindir=@bindir@ + +## Where to install architecture-independent data files. +## ${lispdir} and ${etcdir} are subdirectories of this. +datadir=@datadir@ + +## Where to find XEmacs packages. +pkgdir=@pkgdir@ + +## Where to install and expect the files that XEmacs modifies as it runs. +## These files are all architecture-independent. Right now, the +## only such data is the locking directory; +## ${lockdir} is a subdirectory of this. +statedir=@statedir@ + +## Where to install and expect executable files to be run by XEmacs +## rather than directly by users, and other architecture-dependent data +## ${archlibdir} is a subdirectory of this. +libdir=@libdir@ + +## Where to install XEmacs's man pages, and what extension they should have. +mandir=@mandir@ +manext=.1 + +## Where to install and expect the info files describing XEmacs. In the +## past, this defaulted to a subdirectory of ${prefix}/lib/xemacs, but +## since there are now many packages documented with the texinfo +## system, it is inappropriate to imply that it is part of XEmacs. +infodir=@infodir@ + +## Document me. +## See callproc.c for code which references this. +infopath=@infopath@ + +## Where to find the source code. The source code for XEmacs's C kernel is +## expected to be in ${srcdir}/src, and the source code for XEmacs's +## utility programs is expected to be in ${srcdir}/lib-src. This is +## set by the configure script's `--srcdir' option. +srcdir=@srcdir@ + +## Where the build is done. +blddir=@blddir@ + +## ==================== XEmacs-specific directories ==================== + +## These variables hold the values XEmacs will actually use. They are +## based on the values of the standard Make variables above. + +## Where to install the lisp files distributed with +## XEmacs. This includes the XEmacs version, so that the +## lisp files for different versions of XEmacs will install +## themselves in separate directories. +lispdir=@lispdir@ + +## Directory XEmacs should search for lisp files specific +## to this site (i.e. customizations), before consulting +## ${lispdir}. +sitelispdir=@sitelispdir@ + +## Where XEmacs will search for its lisp files while +## building. This is only used during the process of +## compiling XEmacs, to help XEmacs find its lisp files +## before they've been installed in their final location. +## It's usually identical to lispdir, except that the +## entry for the directory containing the installed lisp +## files has been replaced with ../lisp. This should be a +## colon-separated list of directories. +buildlispdir=${srcdir}/lisp + +## Where to install the other architecture-independent +## data files distributed with XEmacs (like the tutorial, +## the cookie recipes and the Zippy database). This path +## usually contains the XEmacs version number, so the data +## files for multiple versions of XEmacs may be installed +## at once. +etcdir=@etcdir@ + +## Where to create and expect the locking directory, where +## the XEmacs locking code keeps track of which files are +## currently being edited. +lockdir=@lockdir@ + +## Where to put executables to be run by XEmacs rather than +## the user. This path usually includes the XEmacs version +## and configuration name, so that multiple configurations +## for multiple versions of XEmacs may be installed at +## once. +archlibdir=@archlibdir@ + +## ==================== Utility Programs for the Build ==================== + +## Allow the user to specify the install program. +INSTALL = @install_pp@ @INSTALL@ +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ + +## ============================= Targets ============================== + +## Subdirectories to make recursively. `lisp' is not included +## because the compiled lisp files are part of the distribution +## and you cannot remake them without installing XEmacs first. +MAKE_SUBDIR = @MAKE_SUBDIR@ + +## Subdirectories that can be made recursively. +SUBDIR = ${MAKE_SUBDIR} man + +## The makefiles of the directories in ${MAKE_SUBDIR}. +SUBDIR_MAKEFILES = @SUBDIR_MAKEFILES@ + +## Subdirectories to `make install-arch-dep' recursively +INSTALL_ARCH_DEP_SUBDIR = @INSTALL_ARCH_DEP_SUBDIR@ + +## Subdirectories to install, and where they'll go. +## lib-src's makefile knows how to install it, so we don't do that here. +## When installing the info files, we need to do special things to +## avoid nuking an existing dir file, so we don't do that here; +## instead, we have written out explicit code in the `install' targets. +COPYDIR = ${srcdir}/etc ${srcdir}/lisp +COPYDESTS = ${etcdir} ${lispdir} +GENERATED_HEADERS = src/paths.h src/Emacs.ad.h src/puresize-adjust.h src/config.h lwlib/config.h src/sheap-adjust.h +GENERATED_LISP = lisp/finder-inf.el + +all: ${PROGNAME} all-elc info + +${PROGNAME}: ${GENERATED_HEADERS} ${MAKE_SUBDIR} ${GENERATED_LISP} + +## For performance and consistency, no built-in rules +.SUFFIXES: + +.NO_PARALLEL: ${GENERATED_HEADERS} ${MAKE_SUBDIR} dump-elcs +.PHONY: ${SUBDIR} all beta all-elc all-elcs dump-elc dump-elcs autoloads finder + +## Convenience target for XEmacs beta testers +beta: clean all-elc finder + +## Convenience target for XEmacs maintainers +## This would run `make-xemacsdist' if I were really confident that everything +## was turnkey. +dist: all-elc info + +## Convenience target for XEmacs maintainers +## Updates some rarely generated files: +## - configure from configure.in +## - config.values.in from configure +## - src/depend from src/*.[ch] +.PHONY: config configure depend +config: configure depend +configure: ${srcdir}/configure +${srcdir}/configure: ${srcdir}/configure.in + cd ${srcdir} && autoconf + cd ${srcdir} && /bin/sh lib-src/config.values.sh + +depend ${srcdir}/src/depend: + cd ${srcdir}/src && \ + perl ./make-src-depend > depend.tmp && \ + $(RM) depend && mv depend.tmp depend + +## Build XEmacs and recompile out-of-date and missing .elc files along +## the way. +all-elc all-elcs: lib-src lwlib dump-elcs src + MAKE='$(MAKE)' EMACS='./src/$(PROGNAME)' sh ${srcdir}/lib-src/update-elc.sh + +## Sub-target for all-elc. +dump-elc dump-elcs: ${GENERATED_HEADERS} FRC.dump-elcs + cd ./src && $(RECURSIVE_MAKE) dump-elcs + +autoloads: src + MAKE='$(MAKE)' EMACS='./src/$(PROGNAME)' sh ${srcdir}/lib-src/update-autoloads.sh + +custom-loads: + MAKE='$(MAKE)' EMACS='./src/$(PROGNAME)' sh ${srcdir}/lib-src/update-custom.sh + +finder: src + @echo "Building finder database ..." + @(cd ./lisp; \ + ${blddir}/src/${PROGNAME} -batch -vanilla \ + -eval '(setq finder-compile-keywords-quiet t)' \ + -l finder -f finder-compile-keywords ) + @echo "Building finder database ...(done)" + +lisp/finder-inf.el: + @echo "Building finder database ..." + @(cd ./lisp; \ + ${blddir}/src/${PROGNAME} -batch -vanilla \ + -eval '(setq finder-compile-keywords-quiet t)' \ + -l finder -f finder-compile-keywords ) + @echo "Building finder database ...(done)" + +## We have to force the building of Emacs.ad.h as well in order to get it +## updated correctly when VPATH is being used. Since we use move-if-change, +## it will only actually change if the user modified ${etcdir}/Emacs.ad. +src/Emacs.ad.h: ${srcdir}/etc/Emacs.ad + @echo "Producing \`src/Emacs.ad.h' from \`etc/Emacs.ad'." + @$(RM) src/Emacs.ad.h + @(echo "/* Do not edit this file!" ; \ + echo " Automatically generated from ${srcdir}/etc/Emacs.ad" ; \ + echo " */" ; \ + /bin/sh ${srcdir}/lib-src/ad2c ${srcdir}/etc/Emacs.ad ) > \ + src/Emacs.ad.h + +src/puresize-adjust.h: ${srcdir}/src/puresize.h + @echo "Resetting \`src/puresize-adjust.h'."; \ + (echo "/* Do not edit this file!" ; \ + echo " Automatically generated by XEmacs */" ; \ + echo "#define PURESIZE_ADJUSTMENT 0") > $@ + +src/sheap-adjust.h: + @echo "Resetting \`src/sheap-adjust.h'."; \ + (echo "/* Do not edit this file!" ; \ + echo " Automatically generated by XEmacs */" ; \ + echo "#define SHEAP_ADJUSTMENT 0") > $@ + +src: @SRC_SUBDIR_DEPS@ FRC.src +pkg-src/tree-x: pkg-src/FRC.tree-x +lib-src: FRC.lib-src +lwlib: FRC.lwlib +dynodump: FRC.dynodump +FRC.src FRC.lib-src FRC.lwlib FRC.dynodump pkg-src/FRC.tree-x: +FRC.lisp.finder-inf.el: + +${SUBDIR}: ${SUBDIR_MAKEFILES} ${GENERATED_HEADERS} FRC + cd ./$@ && $(RECURSIVE_MAKE) all + +Makefile: ${srcdir}/Makefile.in config.status + ./config.status + +src/Makefile: ${srcdir}/src/Makefile.in.in ${srcdir}/src/depend config.status + ./config.status + +lib-src/Makefile: ${srcdir}/lib-src/Makefile.in.in config.status + ./config.status + +lwlib/Makefile: ${srcdir}/lwlib/Makefile.in.in config.status + ./config.status + +pkg-src/tree-x/Makefile: ${srcdir}/pkg-src/tree-x/Makefile.in.in config.status + ./config.status + +src/config.h: ${srcdir}/src/config.h.in + ./config.status && touch $@ + +src/paths.h: ${srcdir}/src/paths.h.in + ./config.status && touch $@ + +lwlib/config.h: ${srcdir}/lwlib/config.h.in + ./config.status && touch $@ + +## ==================== Installation ==================== + +## If we let lib-src do its own installation, that means we +## don't have to duplicate the list of utilities to install in +## this Makefile as well. + +## On AIX, use tar xBf. +## On Xenix, use tar xpf. + +.PHONY: install-only install install-arch-dep install-arch-indep gzip.el mkdir +.PHONY: check-features + +## We delete each directory in ${COPYDESTS} before we copy into it; +## that way, we can reinstall over directories that have been put in +## place with their files read-only (perhaps because they are checked +## into RCS). In order to make this safe, we make sure that the +## source exists and is distinct from the destination. + +## FSF doesn't depend on `all', but rather on ${MAKE_SUBDIR}, so that +## they "won't ever modify src/paths.h". But that means you can't do +## 'make install' right off the bat because src/paths.h won't exist. +## And, in XEmacs case, src/Emacs.ad.h won't exist either. I also +## don't see the point in avoiding modifying paths.h. It creates an +## inconsistency in the build process. So we go ahead and depend on +## all. --cet + +check-features: all + ${blddir}/src/${PROGNAME} -batch -l check-features.el + +install-only: ${MAKE_SUBDIR} check-features install-arch-dep install-arch-indep + +install: all check-features install-arch-dep install-arch-indep + +install-arch-dep: mkdir + for subdir in ${INSTALL_ARCH_DEP_SUBDIR}; do \ + (cd ./$${subdir} && $(RECURSIVE_MAKE) install prefix=${prefix} \ + exec_prefix=${exec_prefix} bindir=${bindir} libdir=${libdir} \ + archlibdir=${archlibdir}) ; done + if test "`(cd ${archlibdir} && $(pwd))`" != \ + "`(cd ./lib-src && $(pwd))`"; then \ + if test -f ../Installation; then \ + ${INSTALL_DATA} ../Installation ${archlibdir}/Installation; \ + fi; \ + for f in DOC config.values; do \ + ${INSTALL_DATA} lib-src/$${f} ${archlibdir}/$${f}; \ + done ; \ + for subdir in `find ${archlibdir} -type d ! -name RCS ! -name SCCS ! -name CVS -print` ; \ + do (cd $${subdir} && $(RM) -r RCS CVS SCCS \#* *~) ; done ; \ + else true; fi + ${INSTALL_PROGRAM} src/${PROGNAME} ${bindir}/${PROGNAME}-${version} + -chmod 0755 ${bindir}/${PROGNAME}-${version} + cd ${bindir} && $(RM) ./${PROGNAME} && ${LN_S} ${PROGNAME}-${version} ./${PROGNAME} + if test "${prefix}" != "${exec_prefix}"; then \ + for dir in \ + lib/${PROGNAME} \ + lib/${PROGNAME}-${version}/etc \ + lib/${PROGNAME}-${version}/info \ + lib/${PROGNAME}-${version}/lisp; do \ + if test ! -d ${exec_prefix}/$${dir}; then \ + $(LN_S) ${prefix}/$${dir} ${exec_prefix}/$${dir}; fi; \ + done; \ + fi + +install-arch-indep: mkdir info + -@set ${COPYDESTS} ; \ + for dir in ${COPYDIR} ; do \ + if test "`(cd $$1 && $(pwd))`" != \ + "`(cd $${dir} && $(pwd))`"; then \ + : do nothing - echo "rm -rf $$1" ; \ + fi ; \ + shift ; \ + done + -set ${COPYDESTS} ; \ + for dir in ${COPYDESTS} ; do \ + if test ! -d $${dir} ; then mkdir $${dir} ; fi ; \ + done ; \ + for dir in ${COPYDIR} ; do \ + dest=$$1 ; shift ; \ + test -d $${dir} \ + -a "`(cd $${dir} && $(pwd))`" != \ + "`(cd $${dest} && $(pwd))`" \ + && (echo "Copying $${dir}..." ; \ + (cd $${dir} && tar -cf - . ) | \ + (cd $${dest} && umask 022 && tar -xf - );\ + chmod 0755 $${dest}; \ + for subdir in `find $${dest} -type d ! -name RCS ! -name SCCS ! -name CVS -print` ; do \ + (cd $${subdir} && $(RM) -r RCS CVS SCCS \#* *~) ; \ + done) ; \ + done + if test "`(cd ${srcdir}/info && $(pwd))`" != \ + "`(cd ${infodir} && $(pwd))`" && cd ${srcdir}/info; then \ + if test ! -f ${infodir}/dir -a -f dir ; then \ + ${INSTALL_DATA} ${srcdir}/info/dir ${infodir}/dir ; \ + fi ; \ + for file in *.info* ; do \ + ${INSTALL_DATA} $${file} ${infodir}/$${file} ; \ + chmod 0644 ${infodir}/$${file}; \ + done ; \ + fi + ## Note it's `xemacs' not ${PROGNAME} + cd ${srcdir}/etc && \ + for page in xemacs etags ctags gnuserv gnuclient gnuattach gnudoit; do \ + ${INSTALL_DATA} ${srcdir}/etc/$${page}.1 ${mandir}/$${page}${manext} ; \ + chmod 0644 ${mandir}/$${page}${manext} ; \ + done + @echo "If you would like to save approximately 2M of disk space, do" + @echo "make gzip-el" + @echo "or you may run " + @echo ${srcdir}/lib-src/gzip-el.sh lispdir " from the command line." + @echo "Where lispdir is where the lisp files were installed, i.e.," + @echo "${lispdir}" + +gzip-el: + ${srcdir}/lib-src/gzip-el.sh ${lispdir} + +MAKEPATH=./lib-src/make-path +## Build all the directories to install XEmacs in. +## Since we may be creating several layers of directories, +## (e.g. /usr/local/lib/${PROGNAME}-20.5/sparc-sun-solaris2.6), we use +## make-path instead of mkdir. Not all mkdirs have the `-p' flag. +mkdir: FRC.mkdir + ${MAKEPATH} ${COPYDESTS} ${lockdir} ${infodir} ${archlibdir} \ + ${mandir} ${bindir} ${datadir} ${libdir} ${pkgdir} + -chmod 0777 ${lockdir} + +## Delete all the installed files that the `install' target would +## create (but not the noninstalled files such as `make all' would +## create). + +#### Don't delete the lisp and etc directories if they're in the source tree. +#### This target has not been updated in sometime and until it is it +#### would be extremely dangerous for anyone to use it. +##uninstall: +## (cd ./lib-src; \ +## $(RECURSIVE_MAKE) uninstall \ +## prefix=${prefix} exec_prefix=${exec_prefix} \ +## bindir=${bindir} libdir=${libdir} archlibdir=${archlibdir}) +## for dir in ${lispdir} ${etcdir} ; do \ +## case `(cd $${dir} ; $(pwd))` in \ +## `(cd ${srcdir} ; $(pwd))`* ) ;; \ +## * ) $(RM) $${dir} ;; \ +## esac ; \ +## case $${dir} in \ +## ${datadir}/${PROGNAME}/${version}/* ) \ +## $(RM) -r ${datadir}/${PROGNAME}/${version} \ +## ;; \ +## esac ; \ +## done +## cd ${infodir} && $(RM) cl* ${PROGNAME}* forms* info* vip* +## cd ${mandir} && $(RM) xemacs.1 etags.1 ctags.1 gnuserv.1 +## cd ${bindir} && $(RM) ${PROGNAME}-${version} ${PROGNAME} + + +## Some makes seem to remember that they've built something called FRC, +## so you can only use a given FRC once per makefile. +FRC FRC.src.paths.h FRC.mkdir FRC.dump-elcs FRC.info: +FRC.mostlyclean FRC.clean FRC.distclean FRC.realclean FRC.tags: + +## ==================== Cleaning up and miscellanea ==================== + +.PHONY: mostlyclean clean distclean realclean extraclean + +## `mostlyclean' +## Like `clean', but may refrain from deleting a few files that people +## normally don't want to recompile. For example, the `mostlyclean' +## target for GCC does not delete `libgcc.a', because recompiling it +## is rarely necessary and takes a lot of time. +mostlyclean: FRC.mostlyclean + for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + +## `clean' +## Delete all files from the current directory that are normally +## created by building the program. Don't delete the files that +## record the configuration. Also preserve files that could be made +## by building, but normally aren't because the distribution comes +## with them. + +## Delete `.dvi' files here if they are not part of the distribution. +clean: FRC.clean + for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + $(RM) core + +## `distclean' +## Delete all files from the current directory that are created by +## configuring or building the program. If you have unpacked the +## source and built the program without creating any other files, +## `make distclean' should leave only the files that were in the +## distribution. +top_distclean=\ + $(RM) config.status config.log config-tmp-* build-install Installation ; \ + for d in src lib-src lwlib dynodump ; do \ + $(RM) $$d/Makefile $$d/Makefile.in ; \ + done ; \ + $(RM) core .sbinit Makefile Makefile.in lock/*; \ + $(RM) lisp/finder-inf.el* Installation.el Installation.elc; \ + $(RM) packages mule-packages site-lisp + +distclean: FRC.distclean + for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + -${top_distclean} + +## `realclean' +## Delete everything from the current directory that can be +## reconstructed with this Makefile. This typically includes +## everything deleted by distclean, plus more: C source files +## produced by Bison, tags tables, info files, and so on. + +## One exception, however: `make realclean' should not delete +## `configure' even if `configure' can be remade using a rule in the +## Makefile. More generally, `make realclean' should not delete +## anything that needs to exist in order to run `configure' and then +## begin to build the program. +realclean: FRC.realclean + for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + -${top_distclean} + $(RM) TAGS + +## This doesn't actually appear in the coding standards, but Karl +## says GCC supports it, and that's where the configuration part of +## the coding standards seem to come from. It's like distclean, but +## it deletes backup and autosave files too. +extraclean: + for d in $(SUBDIR); do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + $(RM) *~ \#* + -${top_distclean} + +## Unlocking and relocking. The idea of these productions is to reduce +## hassles when installing an incremental tar of XEmacs. Do `make unlock' +## before unlocking the file to take the write locks off all sources so +## that tar xvof will overwrite them without fuss. Then do `make relock' +## afterward so that VC mode will know which files should be checked in +## if you want to mung them. + +## Note: it's no disaster if these productions miss a file or two; tar +## and VC will swiftly let you know if this happens, and it is easily +## corrected. +SOURCES = ChangeLog GETTING.GNU.SOFTWARE INSTALL Makefile.in PROBLEMS \ + README build-install.in configure make-dist move-if-change + +.PHONY: unlock relock TAGS tags check dist info dvi mcs + +unlock: + chmod u+w $(SOURCES) cpp/* + -cd ./elisp && chmod u+w Makefile README *.texi + for d in src etc lib-src lisp; do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + cd ./lisp/term && chmod u+w README *.el + cd ./man && chmod u+w *texi* ChangeLog split-man + cd ./lwlib && chmod u+w *.[ch] Makefile.in.in + +relock: + chmod u-w $(SOURCES) cpp/* + -cd ./elisp && chmod u-w Makefile README *.texi + for d in src etc lib-src lisp; do (cd ./$$d && $(RECURSIVE_MAKE) $@); done + cd ./lisp/term && chmod u+w README *.el + cd ./man && chmod u+w *texi* ChangeLog split-man + cd ./lwlib && chmod u+w *.[ch] Makefile.in.in + +PRUNE_VC = -name SCCS -prune -o -name RCS -prune -o -name CVS -prune -o +tagslisp = lisp +TAGS tags: FRC.tags + @echo "If you don't have a copy of etags around, then do 'make lib-src' first." + $(RM) ${srcdir}/TAGS + @PATH=`$(pwd)`/lib-src:$$PATH HOME=/-=-; export PATH HOME; \ + echo "Using etags from `which etags`." + PATH=`$(pwd)`/lib-src:$$PATH ; export PATH; cd ${srcdir} && \ + find src lwlib lib-src ${PRUNE_VC} -name '*.[ch]' -print | \ + xargs etags -a -r '/[ ]*DEF\(VAR\|INE\)_[A-Z_]+[ ]*([ ]*"\([^"]+\)"/\2/'; \ + find ${tagslisp} ${PRUNE_VC} -name '*.el' ! -name 'auto-autoloads.el' -print | \ + xargs etags -a -l none -r "/^(def\\(var\\|un\\|alias\\|const\\|macro\\|subst\\|struct\\|face\\|group\\|custom\\|ine-\\(function\\|compiler-macro\\|[a-z-]+alias\\)\\)[ ]+'?\\([^ ]+\\)/\\3/" + +check: + cd ./src && $(RECURSIVE_MAKE) $@ + +info: FRC.info + cd ${srcdir}/man && $(RECURSIVE_MAKE) $@ + +dvi: + cd ${srcdir}/man && $(RECURSIVE_MAKE) $@ + +## Fix up version information in executables (Solaris-only) +mcs: + date=`LANG=C LC_ALL=C date -u '+%e %b %Y'`; \ + ident="@(#)RELEASE VERSION XEmacs ${version} $${date}"; \ + for f in `file lib-src/* src/${PROGNAME} | grep ELF | sed -e 's/:.*//'`; do \ + mcs -da "$${ident} `echo $${f} | sed 's/.*\///'`" $${f}; \ + done diff -r 76b7d63099ad -r 8626e4521993 config.guess --- a/config.guess Mon Aug 13 11:06:08 2007 +0200 +++ b/config.guess Mon Aug 13 11:07:10 2007 +0200 @@ -112,6 +112,9 @@ amiga:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit 0 ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit 0 ;; arc64:OpenBSD:*:*) echo mips64el-unknown-openbsd${UNAME_RELEASE} exit 0 ;; @@ -139,7 +142,7 @@ SR2?01:HI-UX/MPP:*:*) echo hppa1.1-hitachi-hiuxmpp exit 0;; - Pyramid*:OSx*:*:*|MIS*:OSx*:*:*) + Pyramid*:OSx*:*:*|MIS*:OSx*:*:*|MIS*:SMP_DC-OSx*:*:*) # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. if test "`(/bin/universe) 2>/dev/null`" = att ; then echo pyramid-pyramid-sysv3 @@ -219,6 +222,9 @@ powerpc:machten:*:*) echo powerpc-apple-machten${UNAME_RELEASE} exit 0 ;; + macppc:NetBSD:*:*) + echo powerpc-apple-netbsd${UNAME_RELEASE} + exit 0 ;; RISC*:Mach:*:*) echo mips-dec-mach_bsd4.3 exit 0 ;; @@ -324,7 +330,8 @@ fi exit 0 ;; *:AIX:*:4) - if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | head -1 | awk '{ print $1 }'` + if /usr/sbin/lsattr -EHl ${IBM_CPU_ID} | grep POWER >/dev/null 2>&1; then IBM_ARCH=rs6000 else IBM_ARCH=powerpc @@ -357,12 +364,44 @@ hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) echo m68k-hp-bsd4.4 exit 0 ;; - 9000/[3478]??:HP-UX:*:*) + 9000/[34678]??:HP-UX:*:*) case "${UNAME_MACHINE}" in 9000/31? ) HP_ARCH=m68000 ;; 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/7?? | 9000/8?[1679] ) HP_ARCH=hppa1.1 ;; - 9000/8?? ) HP_ARCH=hppa1.0 ;; + 9000/6?? | 9000/7?? | 9000/80[24] | 9000/8?[13679] | 9000/892 ) + sed 's/^ //' << EOF >dummy.c + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + ${CC-cc} dummy.c -o dummy && HP_ARCH=`./dummy` + rm -f dummy.c dummy esac HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` echo ${HP_ARCH}-hp-hpux${HPUX_REV} @@ -468,6 +507,9 @@ hp300:OpenBSD:*:*) echo m68k-unknown-openbsd${UNAME_RELEASE} exit 0 ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; i?86:BSD/386:*:* | *:BSD/OS:*:*) echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} exit 0 ;; @@ -662,6 +704,13 @@ echo ${UNAME_MACHINE}-pc-sysv32 fi exit 0 ;; + i?86:UnixWare:*:*) + if /bin/uname -X 2>/dev/null >/dev/null ; then + (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + fi + echo ${UNAME_MACHINE}-unixware-${UNAME_RELEASE}-${UNAME_VERSION} + exit 0 ;; pc:*:*:*) # uname -m prints for DJGPP always 'pc', but it prints nothing about # the processor, so we play safe by assuming i386. @@ -745,13 +794,22 @@ news*:NEWS-OS:*:6*) echo mips-sony-newsos6 exit 0 ;; - R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:*) + R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R4000:UNIX_SV:*:*) if [ -d /usr/nec ]; then echo mips-nec-sysv${UNAME_RELEASE} else echo mips-unknown-sysv${UNAME_RELEASE} fi exit 0 ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit 0 ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit 0 ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit 0 ;; esac #echo '(No uname command or uname output not recognized.)' 1>&2 diff -r 76b7d63099ad -r 8626e4521993 config.sub --- a/config.sub Mon Aug 13 11:06:08 2007 +0200 +++ b/config.sub Mon Aug 13 11:07:10 2007 +0200 @@ -1,6 +1,6 @@ #! /bin/sh # Configuration validation subroutine script, version 1.1. -# Copyright (C) 1991, 92, 93, 94, 95, 1996 Free Software Foundation, Inc. +# Copyright (C) 1991, 92-97, 1998 Free Software Foundation, Inc. # This file is (in principle) common to ALL GNU software. # The presence of a machine in this file suggests that SOME GNU software # can handle that machine. It does not imply ALL GNU software can. @@ -20,8 +20,6 @@ # Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. -# Synched up with: FSF 19.31. - # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under @@ -43,6 +41,8 @@ # The goal of this file is to map all the various variations of a given # machine specification into a single specification in the form: # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM # It is wrong to echo any other type of specification. if [ x$1 = x ] @@ -64,11 +64,21 @@ ;; esac -# Separate what the user gave into CPU-COMPANY and OS (if any). -basic_machine=`echo $1 | sed 's/-[^-]*$//'` -if [ $basic_machine != $1 ] -then os=`echo $1 | sed 's/.*-/-/'` -else os=; fi +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + linux-gnu*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac ### Let's recognize common machines as not being operating systems so ### that things like config.sub decstation-3100 work. We also @@ -93,33 +103,33 @@ ;; -sco5) os=sco3.2v5 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco4) os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco3.2v[4-9]*) # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -sco*) os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -isc) os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -clix*) basic_machine=clipper-intergraph ;; -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` ;; -lynx*) os=-lynxos @@ -139,32 +149,40 @@ case $basic_machine in # Recognize the basic CPU types without company name. # Some are omitted here because they have special meanings below. - tahoe | i[3-9]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ - | arme[lb] | pyramid \ - | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ - | alpha | we32k | mab | ns16k | clipper | i370 | sh \ - | powerpc | powerpcle | 1750a | dsp16xx | mips64 | mipsel \ - | pdp11 | mips64el | mips64orion | mips64orionel \ - | sparc | sparclet | sparclite | sparc64) + tahoe | i860 | m32r | m68k | m68000 | m88k | ns32k | arc | arm \ + | arme[lb] | pyramid | mn10200 | mn10300 | tron | a29k \ + | 580 | i960 | h8300 | hppa | hppa1.0 | hppa1.1 | hppa2.0 \ + | alpha | alphaev5 | alphaev56 | we32k | ns16k | clipper \ + | i370 | sh | powerpc | powerpcle | 1750a | dsp16xx | pdp11 \ + | mips64 | mipsel | mips64el | mips64orion | mips64orionel \ + | mipstx39 | mipstx39el \ + | sparc | sparclet | sparclite | sparc64 | v850) basic_machine=$basic_machine-unknown ;; + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i[34567]86) + basic_machine=$basic_machine-pc + ;; # Object if more than one company name word. *-*-*) echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 exit 1 ;; # Recognize the basic CPU types with company name. - vax-* | tahoe-* | i[3-9]86-* | i860-* | m68k-* | m68000-* | m88k-* \ - | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ - | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \ - | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \ - | hppa1.0-* | hppa1.1-* | alpha*-* | we32k-* | cydra-* | ns16k-* \ - | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \ - | pdp11-* | sh-* | powerpc-* | powerpcle-* | sparc64-* | mips64-* | mipsel-* \ - | mips64el-* | mips64orion-* | mips64orionel-* | mab-*) - ;; - # Recognize names of some NetBSD ports. - amiga-* | hp300-* | mac68k-* | sun3-* | pmax-*) + vax-* | tahoe-* | i[34567]86-* | i860-* | m32r-* | m68k-* | m68000-* \ + | m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | arm-* | c[123]* \ + | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \ + | power-* | none-* | 580-* | cray2-* | h8300-* | i960-* \ + | xmp-* | ymp-* | hppa-* | hppa1.0-* | hppa1.1-* | hppa2.0-* \ + | alpha-* | alphaev5-* | alphaev56-* | we32k-* | cydra-* \ + | ns16k-* | pn-* | np1-* | xps100-* | clipper-* | orion-* \ + | sparclite-* | pdp11-* | sh-* | powerpc-* | powerpcle-* \ + | sparc64-* | mips64-* | mipsel-* \ + | mips64el-* | mips64orion-* | mips64orionel-* \ + | mipstx39-* | mipstx39el-* \ + | f301-*) ;; # Recognize the various machine names and aliases which stand # for a CPU type and a company and sometimes even an OS. @@ -191,9 +209,9 @@ amiga | amiga-*) basic_machine=m68k-cbm ;; - amigados) + amigaos | amigados) basic_machine=m68k-cbm - os=-amigados + os=-amigaos ;; amigaunix | amix) basic_machine=m68k-cbm @@ -207,10 +225,6 @@ basic_machine=m68k-apple os=-aux ;; - aux) - basic_machine=m68k-apple - os=-aux - ;; balance) basic_machine=ns32k-sequent os=-dynix @@ -328,25 +342,28 @@ hp9k8[0-9][0-9] | hp8[0-9][0-9]) basic_machine=hppa1.0-hp ;; + hppa-next) + os=-nextstep3 + ;; i370-ibm* | ibm*) basic_machine=i370-ibm os=-mvs ;; # I'm not sure what "Sysv32" means. Should this be sysv3.2? - i[3-9]86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv32 ;; - i[3-9]86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv4 ;; - i[3-9]86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-sysv ;; - i[3-9]86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + i[34567]86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` os=-solaris2 ;; iris | iris4d) @@ -377,6 +394,14 @@ miniframe) basic_machine=m68000-convergent ;; + mipsel*-linux*) + basic_machine=mipsel-unknown + os=-linux-gnu + ;; + mips*-linux*) + basic_machine=mips-unknown + os=-linux-gnu + ;; mips3*-*) basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` ;; @@ -442,34 +467,25 @@ basic_machine=m68k-tti ;; pc532 | pc532-*) - case $os in - -netbsd*) - basic_machine=pc532-unknown - ;; - *) - basic_machine=ns32k-pc532 - ;; - esac + basic_machine=ns32k-pc532 + ;; + pentium | p5 | k5 | nexen) + basic_machine=i586-pc ;; - pentium | p5) - basic_machine=i586-intel + pentiumpro | p6 | k6 | 6x86) + basic_machine=i686-pc ;; - pentiumpro | p6) - basic_machine=i686-intel + pentiumii | pentium2) + basic_machine=i786-pc ;; - pentium-* | p5-*) + pentium-* | p5-* | k5-* | nexen-*) basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - pentiumpro-* | p6-*) + pentiumpro-* | p6-* | k6-* | 6x86-*) basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` ;; - k5) - # We don't have specific support for AMD's K5 yet, so just call it a Pentium - basic_machine=i586-amd - ;; - nexen) - # We don't have specific support for Nexgen yet, so just call it a Pentium - basic_machine=i586-nexgen + pentiumii-* | pentium2-*) + basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'` ;; pn) basic_machine=pn-gould @@ -553,6 +569,12 @@ basic_machine=i386-sequent os=-dynix ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; tower | tower-32) basic_machine=m68k-ncr ;; @@ -572,6 +594,9 @@ basic_machine=vax-dec os=-vms ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; vxworks960) basic_machine=i960-wrs os=-vxworks @@ -599,7 +624,11 @@ # Here we handle the default manufacturer of certain CPU types. It is in # some cases the only manufacturer, in others, it is the most popular. mips) - basic_machine=mips-mips + if [ x$os = x-linux-gnu ]; then + basic_machine=mips-unknown + else + basic_machine=mips-mips + fi ;; romp) basic_machine=romp-ibm @@ -651,6 +680,8 @@ if [ x"$os" != x"" ] then case $os in + # First match some system type aliases + # that might get confused with valid system types. # -solaris* is a basic system type, with this one exception. -solaris1 | -solaris1.*) os=`echo $os | sed -e 's|solaris1|sunos4|'` @@ -658,29 +689,37 @@ -solaris) os=-solaris2 ;; - -unixware* | svr4*) + -svr4*) os=-sysv4 ;; + -unixware*) + os=-sysv4.2uw + ;; -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux|'` + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` ;; # First accept the basic system types. # The portable systems comes first. # Each alternative MUST END IN A *, to match a version number. # -sysv* is not here because it comes later, after sysvr4. -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigados* | -msdos* | -newsos* | -unicos* | -aof* | -aos* \ - | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ - | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ - | -cygwin32* | -pe* | -psos* | -moss* | -openbsd* ) + | -cygwin32* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv* | -beos*) # Remember, each alternative MUST END IN *, to match a version number. ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; -sunos5*) os=`echo $os | sed -e 's|sunos5|solaris2|'` ;; @@ -788,6 +827,9 @@ sparc-* | *-sun) os=-sunos4.1.1 ;; + *-be) + os=-beos + ;; *-ibm) os=-aix ;; @@ -801,7 +843,7 @@ os=-sysv ;; *-cbm) - os=-amigados + os=-amigaos ;; *-dg) os=-dgux @@ -851,6 +893,9 @@ *-masscomp) os=-rtu ;; + f301-fujitsu) + os=-uxpv + ;; *) os=-none ;; @@ -869,9 +914,6 @@ -sunos*) vendor=sun ;; - -lynxos*) - vendor=lynx - ;; -aix*) vendor=ibm ;; @@ -899,14 +941,12 @@ -ptx*) vendor=sequent ;; - -vxworks*) + -vxsim* | -vxworks*) vendor=wrs ;; -aux*) vendor=apple ;; - -aux*) - vendor=apple esac basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` ;; diff -r 76b7d63099ad -r 8626e4521993 configure --- a/configure Mon Aug 13 11:06:08 2007 +0200 +++ b/configure Mon Aug 13 11:07:10 2007 +0200 @@ -299,13 +299,11 @@ case "$opt" in - run_in_place | \ - with_site_lisp | \ + with_site_lisp | \ with_x | \ with_x11 | \ with_msw | \ with_gcc | \ - with_gnu_make | \ dynamic | \ with_ncurses | \ with_dnet | \ @@ -322,19 +320,20 @@ with_tiff | \ with_session | \ with_xmu | \ + with_purify | \ with_quantify | \ with_toolbars | \ with_tty | \ with_xfs | \ with_i18n3 | \ with_mule | \ - with_file_coding | \ + with_file_coding| \ with_canna | \ with_wnn | \ with_wnn6 | \ with_workshop | \ with_sparcworks | \ - with_tooltalk | \ + with_tooltalk | \ with_ldap | \ with_pop | \ with_kerberos | \ @@ -345,26 +344,25 @@ verbose | \ extra_verbose | \ const_is_losing | \ - usage_tracking | \ - use_union_type | \ + usage_tracking | \ + use_union_type | \ debug | \ use_assertions | \ + gung_ho | \ use_minimal_tagbits | \ use_indexed_lrecord_implementation | \ - gung_ho | \ - use_assertions | \ memory_usage_stats | \ with_clash_detection | \ with_shlib | \ no_doc_file ) case "$val" in y | ye | yes ) val=yes ;; - n | no ) val=no ;; + n | no ) val=no ;; * ) (echo "$progname: Usage error:" echo " " "The \`--$optname' option requires a boolean value: \`yes' or \`no'." echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; esac - eval "$opt=\"$val\"" ;; + eval "$opt=\"$val\"" ;; srcdir | \ @@ -376,7 +374,7 @@ ldflags | \ puresize | \ cache_file | \ - native_sound_lib | \ + native_sound_lib| \ site_lisp | \ x_includes | \ x_libraries | \ @@ -425,7 +423,7 @@ * ) (echo "$progname: Usage error:" echo " " "The \`--$optname' option value must be either \`no' or a comma-separated list - of one or more of \`berkdb', \`dbm', or \`gnudbm'." + of one or more of \`berkdb' and either \`dbm' or \`gnudbm'." echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; esac done @@ -467,18 +465,6 @@ eval "$opt=\"$val\"" ;; - "with_xfs" ) - case "$val" in - y | ye | yes ) val=yes ;; - n | no | non | none ) val=no ;; - * ) (echo "$progname: Usage error:" -echo " " "The \`--$optname' option must have one of these values: - \`yes', or \`no'." -echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; - esac - eval "$opt=\"$val\"" - ;; - "mail_locking" ) case "$val" in lockf ) val=lockf ;; @@ -542,7 +528,7 @@ prefix | exec_prefix | bindir | datadir | statedir | libdir | \ mandir | infodir | infopath | lispdir | etcdir | lockdir | pkgdir | \ - archlibdir | docdir | package_path ) + archlibdir | docdir | package_path ) if test "$valomitted" = "yes"; then if test "$#" = 0; then (echo "$progname: Usage error:" @@ -642,7 +628,9 @@ "usage" | "help" ) ${PAGER-more} ${srcdir}/configure.usage; exit 0 ;; - "with_menubars" | "with_scrollbars" | "with_dialogs" ) + "with_menubars" | \ + "with_scrollbars" | \ + "with_dialogs" ) case "$val" in l | lu | luc | luci | lucid ) val=lucid ;; m | mo | mot | moti | motif ) val=motif ;; @@ -657,6 +645,11 @@ eval "$opt=\"$val\"" ;; + "run_in_place" | \ + "with_gnu_make" ) + echo "configure: warning: Obsolete option \`--$optname' ignored." 1>&2 + ;; + * ) (echo "$progname: Usage error:" echo " " "Unrecognized option: $arg" echo " Use \`$progname --help' to show usage.") >&2 && exit 1 ;; @@ -683,13 +676,11 @@ test "$extra_verbose" = "yes" && verbose=yes -case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac -case "$site_libraries" in *:* ) site_libraries="`echo '' $site_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac -case "$site_prefixes" in *:* ) site_prefixes="`echo '' $site_prefixes | sed -e 's/^ //' -e 's/:/ /g'`";; esac -case "$site_runtime_libraries" in *:* ) site_runtime_libraries="`echo '' $site_runtime_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac - test -n "$with_x" && with_x11="$with_x" +if test "$with_purify" = "yes" -o "$with_quantify" = "yes"; then + test "$with_system_malloc" = "default" && with_system_malloc=yes +fi if test -n "$gung_ho"; then test -z "$use_minimal_tagbits" && use_minimal_tagbits="$gung_ho" @@ -715,10 +706,6 @@ fi -if test "$run_in_place" = "yes"; then - echo "configure: warning: "The --run-in-place option is ignored because it is unnecessary."" 1>&2 -fi - case "$srcdir" in "" ) @@ -754,13 +741,8 @@ esac if test -z "$configuration"; then - echo $ac_n "checking "host system type"""... $ac_c" 1>&6 -echo "configure:759: checking "host system type"" >&5 - if configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess | \ - sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` ; then - echo "$ac_t""$configuration" 1>&6 - else - echo "$ac_t""unknown" 1>&6 + configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess` + if test -z "$configuration"; then (echo "$progname: Usage error:" echo " " "XEmacs has not been ported to this host type. Try explicitly specifying the CONFIGURATION when rerunning configure." @@ -769,7 +751,7 @@ fi echo $ac_n "checking whether ln -s works""... $ac_c" 1>&6 -echo "configure:773: checking whether ln -s works" >&5 +echo "configure:755: checking whether ln -s works" >&5 rm -f conftestdata if ln -s X conftestdata 2>/dev/null @@ -984,12 +966,13 @@ -echo "checking "the configuration name"" 1>&6 -echo "configure:989: checking "the configuration name"" >&5 +echo $ac_n "checking "host system type"""... $ac_c" 1>&6 +echo "configure:971: checking "host system type"" >&5 internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'` -if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else - exit $? -fi +canonical=`${CONFIG_SHELL-/bin/sh} $srcdir/config.sub "$internal_configuration"` +configuration=`echo "$configuration" | sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` +canonical=`echo "$canonical" | sed 's/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/'` +echo "$ac_t""$configuration" 1>&6 @@ -1012,6 +995,8 @@ m68*-sony-* ) machine=news ;; mips-sony-* ) machine=news-risc ;; clipper-* ) machine=clipper ;; + arm-* ) machine=arm ;; + ns32k-* ) machine=ns32000 ;; esac case "$canonical" in @@ -1074,13 +1059,9 @@ *-*-openbsd* ) case "${canonical}" in - alpha*-*-openbsd*) machine=alpha ;; i386-*-openbsd*) machine=intel386 ;; m68k-*-openbsd*) machine=hp9000s300 ;; mipsel-*-openbsd*) machine=pmax ;; - ns32k-*-openbsd*) machine=ns32000 ;; - sparc-*-openbsd*) machine=sparc ;; - vax-*-openbsd*) machine=vax ;; esac ;; @@ -1377,8 +1358,6 @@ m68k-*-linux* ) machine=m68k opsys=linux ;; - arm-*-linux* ) machine=arm opsys=linux ;; - esac if test -z "$machine" -o -z "$opsys"; then @@ -1477,7 +1456,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1481: checking for $ac_word" >&5 +echo "configure:1460: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1503,7 +1482,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1507: checking for $ac_word" >&5 +echo "configure:1486: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1548,7 +1527,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1552: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1531: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1560,11 +1539,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1547: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1584,19 +1563,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1588: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1567: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1593: checking whether we are using GNU C" >&5 +echo "configure:1572: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1579: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1610,7 +1589,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1614: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1593: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1639,7 +1618,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1643: checking for $ac_word" >&5 +echo "configure:1622: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1665,7 +1644,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1669: checking for $ac_word" >&5 +echo "configure:1648: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1710,7 +1689,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1714: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1693: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1722,11 +1701,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1709: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1746,19 +1725,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1750: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1729: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1755: checking whether we are using GNU C" >&5 +echo "configure:1734: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1741: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1772,7 +1751,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1776: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1755: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1801,7 +1780,7 @@ # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1805: checking for $ac_word" >&5 +echo "configure:1784: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1827,7 +1806,7 @@ # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:1831: checking for $ac_word" >&5 +echo "configure:1810: checking for $ac_word" >&5 if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. @@ -1872,7 +1851,7 @@ fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:1876: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 +echo "configure:1855: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 ac_ext=c xe_cppflags='$CPPFLAGS $c_switch_site $c_switch_machine $c_switch_system $c_switch_x_site $X_CFLAGS' @@ -1884,11 +1863,11 @@ cross_compiling=no cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:1871: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then ac_cv_prog_cc_works=yes # If we can't run a trivial program, we are probably using a cross compiler. if (./conftest; exit) 2>/dev/null; then @@ -1908,19 +1887,19 @@ { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } fi echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:1912: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "configure:1891: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 cross_compiling=$ac_cv_prog_cc_cross echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:1917: checking whether we are using GNU C" >&5 +echo "configure:1896: checking whether we are using GNU C" >&5 cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then +if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:1903: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then ac_cv_prog_gcc=yes else ac_cv_prog_gcc=no @@ -1934,7 +1913,7 @@ ac_save_CFLAGS="$CFLAGS" CFLAGS= echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:1938: checking whether ${CC-cc} accepts -g" >&5 +echo "configure:1917: checking whether ${CC-cc} accepts -g" >&5 echo 'void f(){}' > conftest.c if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then @@ -1967,7 +1946,7 @@ test -n "$NON_GNU_CPP" -a "$GCC" != "yes" -a -z "$CPP" && CPP="$NON_GNU_CPP" echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:1971: checking how to run the C preprocessor" >&5 +echo "configure:1950: checking how to run the C preprocessor" >&5 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= @@ -1980,13 +1959,13 @@ # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1990: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:1969: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -1997,13 +1976,13 @@ rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2007: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:1986: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : @@ -2026,9 +2005,9 @@ echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:2030: checking for AIX" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&6 -echo "configure:2059: checking for GNU libc" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { @@ -2069,7 +2048,7 @@ ; return 0; } EOF -if { (eval echo configure:2073: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:2052: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* have_glibc=yes else @@ -2091,7 +2070,7 @@ cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:2086: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then : else @@ -2278,7 +2257,7 @@ EOF -CPP=`eval "echo $CPP"` +CPP=`eval "echo $CPP $CPPFLAGS"` eval `$CPP -Isrc $tempcname \ | sed -n -e "s/[ ]*=[ \"]*/='/" -e "s/[ \"]*\$/'/" -e "s/^configure___//p"` @@ -2314,8 +2293,8 @@ set x $ld_switch_system; shift; ld_switch_system="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_system="$ld_switch_system $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_system="$ld_switch_system $1" ;; + -L | -l | -u ) ld_switch_system="$ld_switch_system $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_system="$ld_switch_system $1" ;; -Xlinker* ) ;; * ) ld_switch_system="$ld_switch_system -Xlinker $1" ;; esac @@ -2327,8 +2306,8 @@ set x $ld_switch_machine; shift; ld_switch_machine="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_machine="$ld_switch_machine $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_machine="$ld_switch_machine $1" ;; + -L | -l | -u ) ld_switch_machine="$ld_switch_machine $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_machine="$ld_switch_machine $1" ;; -Xlinker* ) ;; * ) ld_switch_machine="$ld_switch_machine -Xlinker $1" ;; esac @@ -2340,8 +2319,8 @@ set x $LDFLAGS; shift; LDFLAGS="" while test -n "$1"; do case $1 in - -L | -l | -u ) LDFLAGS="$LDFLAGS $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) LDFLAGS="$LDFLAGS $1" ;; + -L | -l | -u ) LDFLAGS="$LDFLAGS $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) LDFLAGS="$LDFLAGS $1" ;; -Xlinker* ) ;; * ) LDFLAGS="$LDFLAGS -Xlinker $1" ;; esac @@ -2353,8 +2332,8 @@ set x $ld_call_shared; shift; ld_call_shared="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_call_shared="$ld_call_shared $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_call_shared="$ld_call_shared $1" ;; + -L | -l | -u ) ld_call_shared="$ld_call_shared $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_call_shared="$ld_call_shared $1" ;; -Xlinker* ) ;; * ) ld_call_shared="$ld_call_shared -Xlinker $1" ;; esac @@ -2373,7 +2352,7 @@ fi echo $ac_n "checking for dynodump""... $ac_c" 1>&6 -echo "configure:2377: checking for dynodump" >&5 +echo "configure:2356: checking for dynodump" >&5 if test "$unexec" != "unexsol2.o"; then echo "$ac_t""no" 1>&6 else @@ -2411,12 +2390,12 @@ done echo $ac_n "checking for terminateAndUnload in -lC""... $ac_c" 1>&6 -echo "configure:2415: checking for terminateAndUnload in -lC" >&5 +echo "configure:2394: checking for terminateAndUnload in -lC" >&5 ac_lib_var=`echo C'_'terminateAndUnload | sed 'y%./+-%__p_%'` xe_check_libs=" -lC " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2410: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -2465,36 +2444,56 @@ -if test -n "$site_prefixes"; then - for arg in $site_prefixes; do - case "$arg" in - -* ) ;; - * ) argi="-I${arg}/include" ; argl="-L${arg}/lib" ;; - esac - c_switch_site="$c_switch_site $argi" && if test "$extra_verbose" = "yes"; then echo " Appending \"$argi\" to \$c_switch_site"; fi - ld_switch_site="$ld_switch_site $argl" && if test "$extra_verbose" = "yes"; then echo " Appending \"$argl\" to \$ld_switch_site"; fi - done -fi - +case "$site_libraries" in *:* ) site_libraries="`echo '' $site_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac if test -n "$site_libraries"; then for arg in $site_libraries; do - case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + { echo "Invalid site library \`$arg': no such directory" >&2; exit 1; } + arg="-L${arg}" ;; + esac ld_switch_site="$ld_switch_site $arg" && if test "$extra_verbose" = "yes"; then echo " Appending \"$arg\" to \$ld_switch_site"; fi done fi +case "$site_includes" in *:* ) site_includes="`echo '' $site_includes | sed -e 's/^ //' -e 's/:/ /g'`";; esac if test -n "$site_includes"; then for arg in $site_includes; do - case "$arg" in -* ) ;; * ) arg="-I${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + { echo "Invalid site include \`$arg': no such directory" >&2; exit 1; } + arg="-I${arg}" ;; + esac c_switch_site="$c_switch_site $arg" && if test "$extra_verbose" = "yes"; then echo " Appending \"$arg\" to \$c_switch_site"; fi done fi +case "$site_prefixes" in *:* ) site_prefixes="`echo '' $site_prefixes | sed -e 's/^ //' -e 's/:/ /g'`";; esac +if test -n "$site_prefixes"; then + for dir in $site_prefixes; do + inc_dir="${dir}/include" + lib_dir="${dir}/lib" + if test ! -d "$dir"; then + { echo "Invalid site prefix \`$dir': no such directory" >&2; exit 1; } + elif test ! -d "$inc_dir"; then + { echo "Invalid site prefix \`$dir': no such directory \`$inc_dir'" >&2; exit 1; } + elif test ! -d "$lib_dir"; then + { echo "Invalid site prefix \`$dir': no such directory \`$lib_dir'" >&2; exit 1; } + else + c_switch_site="$c_switch_site "-I$inc_dir"" && if test "$extra_verbose" = "yes"; then echo " Appending \""-I$inc_dir"\" to \$c_switch_site"; fi + ld_switch_site="$ld_switch_site "-L$lib_dir"" && if test "$extra_verbose" = "yes"; then echo " Appending \""-L$lib_dir"\" to \$ld_switch_site"; fi + fi + done +fi + for dir in "/usr/ccs/lib"; do test -d "$dir" && ld_switch_site="$ld_switch_site -L${dir}" && if test "$extra_verbose" = "yes"; then echo " Appending \"-L${dir}\" to \$ld_switch_site"; fi done +case "$site_runtime_libraries" in *:* ) site_runtime_libraries="`echo '' $site_runtime_libraries | sed -e 's/^ //' -e 's/:/ /g'`";; esac if test -n "$site_runtime_libraries"; then LD_RUN_PATH="`echo $site_runtime_libraries | sed -e 's/ */:/g'`" export LD_RUN_PATH @@ -2511,7 +2510,7 @@ if test "$add_runtime_path" = "yes"; then echo $ac_n "checking "for runtime libraries flag"""... $ac_c" 1>&6 -echo "configure:2515: checking "for runtime libraries flag"" >&5 +echo "configure:2514: checking "for runtime libraries flag"" >&5 case "$opsys" in sol2 ) dash_r="-R" ;; decosf* | linux* ) dash_r="-rpath " ;; @@ -2524,8 +2523,8 @@ set x $xe_check_libs; shift; xe_check_libs="" while test -n "$1"; do case $1 in - -L | -l | -u ) xe_check_libs="$xe_check_libs $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) xe_check_libs="$xe_check_libs $1" ;; + -L | -l | -u ) xe_check_libs="$xe_check_libs $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) xe_check_libs="$xe_check_libs $1" ;; -Xlinker* ) ;; * ) xe_check_libs="$xe_check_libs -Xlinker $1" ;; esac @@ -2533,14 +2532,14 @@ done fi cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +#line 2536 "configure" +#include "confdefs.h" + +int main() { + +; return 0; } +EOF +if { (eval echo configure:2543: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* dash_r="$try_dash_r" else @@ -2619,8 +2618,8 @@ set x $ld_switch_run; shift; ld_switch_run="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;; + -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;; -Xlinker* ) ;; * ) ld_switch_run="$ld_switch_run -Xlinker $1" ;; esac @@ -2641,10 +2640,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2670: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_malloc_get_state=yes" else @@ -2687,10 +2686,10 @@ fi echo $ac_n "checking for malloc_set_state""... $ac_c" 1>&6 -echo "configure:2691: checking for malloc_set_state" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2716: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_malloc_set_state=yes" else @@ -2733,16 +2732,16 @@ fi echo $ac_n "checking whether __after_morecore_hook exists""... $ac_c" 1>&6 -echo "configure:2737: checking whether __after_morecore_hook exists" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:2745: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 else @@ -2801,7 +2800,7 @@ # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2805: checking for $ac_word" >&5 +echo "configure:2804: checking for $ac_word" >&5 if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. @@ -2854,7 +2853,7 @@ # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:2858: checking for a BSD compatible install" >&5 +echo "configure:2857: checking for a BSD compatible install" >&5 if test -z "$INSTALL"; then IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" @@ -2905,7 +2904,7 @@ # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:2909: checking for $ac_word" >&5 +echo "configure:2908: checking for $ac_word" >&5 if test -n "$YACC"; then ac_cv_prog_YACC="$YACC" # Let the user override the test. @@ -2936,15 +2935,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2948: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2947: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -2977,15 +2976,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2989: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:2988: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3014,19 +3013,19 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:3030: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:3029: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3056,10 +3055,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3075,7 +3074,7 @@ s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; ; return 0; } EOF -if { (eval echo configure:3079: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3078: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_sys_wait_h=yes else @@ -3099,10 +3098,10 @@ fi echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:3103: checking for ANSI C header files" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3110,7 +3109,7 @@ #include EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:3114: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:3113: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -3127,7 +3126,7 @@ if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -3145,7 +3144,7 @@ if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF @@ -3163,7 +3162,7 @@ if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') @@ -3174,7 +3173,7 @@ exit (0); } EOF -if { (eval echo configure:3178: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3177: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then : else @@ -3200,10 +3199,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3212,7 +3211,7 @@ struct tm *tp; ; return 0; } EOF -if { (eval echo configure:3216: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3215: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_header_time=yes else @@ -3236,10 +3235,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3251,7 +3250,7 @@ char *msg = *(sys_siglist + 1); ; return 0; } EOF -if { (eval echo configure:3255: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3254: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_decl_sys_siglist=yes else @@ -3276,9 +3275,9 @@ echo $ac_n "checking for struct utimbuf""... $ac_c" 1>&6 -echo "configure:3280: checking for struct utimbuf" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < @@ -3297,7 +3296,7 @@ static struct utimbuf x; x.actime = x.modtime; ; return 0; } EOF -if { (eval echo configure:3301: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3300: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -3317,10 +3316,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3337,7 +3336,7 @@ int i; ; return 0; } EOF -if { (eval echo configure:3341: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3340: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_type_signal=void else @@ -3359,10 +3358,10 @@ echo $ac_n "checking for size_t""... $ac_c" 1>&6 -echo "configure:3363: checking for size_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3393,10 +3392,10 @@ fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 -echo "configure:3397: checking for pid_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3427,10 +3426,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF @@ -3466,10 +3465,10 @@ fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:3470: checking for mode_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3500,10 +3499,10 @@ fi echo $ac_n "checking for off_t""... $ac_c" 1>&6 -echo "configure:3504: checking for off_t" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #if STDC_HEADERS @@ -3535,9 +3534,9 @@ echo $ac_n "checking for struct timeval""... $ac_c" 1>&6 -echo "configure:3539: checking for struct timeval" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < @@ -3553,7 +3552,7 @@ static struct timeval x; x.tv_sec = x.tv_usec; ; return 0; } EOF -if { (eval echo configure:3557: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3556: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 HAVE_TIMEVAL=yes @@ -3575,10 +3574,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include @@ -3586,7 +3585,7 @@ struct tm *tp; tp->tm_sec; ; return 0; } EOF -if { (eval echo configure:3590: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3589: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm=time.h else @@ -3610,10 +3609,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #include <$ac_cv_struct_tm> @@ -3621,7 +3620,7 @@ struct tm tm; tm.tm_zone; ; return 0; } EOF -if { (eval echo configure:3625: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3624: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_struct_tm_zone=yes else @@ -3644,10 +3643,10 @@ else echo $ac_n "checking for tzname""... $ac_c" 1>&6 -echo "configure:3648: checking for tzname" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < #ifndef tzname /* For SGI. */ @@ -3657,7 +3656,7 @@ atoi(*tzname); ; return 0; } EOF -if { (eval echo configure:3661: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:3660: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_var_tzname=yes else @@ -3683,10 +3682,10 @@ echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:3687: checking for working const" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3738: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_const=yes else @@ -3760,7 +3759,7 @@ echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:3764: checking whether ${MAKE-make} sets \${MAKE}" >&5 +echo "configure:3763: checking whether ${MAKE-make} sets \${MAKE}" >&5 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` cat > conftestmake <<\EOF @@ -3785,12 +3784,12 @@ echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 -echo "configure:3789: checking whether byte ordering is bigendian" >&5 +echo "configure:3788: checking whether byte ordering is bigendian" >&5 ac_cv_c_bigendian=unknown # See if sys/param.h defines the BYTE_ORDER macro. cat > conftest.$ac_ext < #include @@ -3801,11 +3800,11 @@ #endif ; return 0; } EOF -if { (eval echo configure:3805: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3804: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* # It does; now see whether it defined to BIG_ENDIAN or not. cat > conftest.$ac_ext < #include @@ -3816,7 +3815,7 @@ #endif ; return 0; } EOF -if { (eval echo configure:3820: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:3819: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_bigendian=yes else @@ -3833,7 +3832,7 @@ rm -f conftest* if test $ac_cv_c_bigendian = unknown; then cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3849: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_c_bigendian=no else @@ -3873,10 +3872,10 @@ echo $ac_n "checking size of short""... $ac_c" 1>&6 -echo "configure:3877: checking size of short" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3887,7 +3886,7 @@ exit(0); } EOF -if { (eval echo configure:3891: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_short=`cat conftestval` else @@ -3915,10 +3914,10 @@ exit 1 fi echo $ac_n "checking size of int""... $ac_c" 1>&6 -echo "configure:3919: checking size of int" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3929,7 +3928,7 @@ exit(0); } EOF -if { (eval echo configure:3933: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3932: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_int=`cat conftestval` else @@ -3951,10 +3950,10 @@ echo $ac_n "checking size of long""... $ac_c" 1>&6 -echo "configure:3955: checking size of long" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -3965,7 +3964,7 @@ exit(0); } EOF -if { (eval echo configure:3969: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:3968: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_long=`cat conftestval` else @@ -3987,10 +3986,10 @@ echo $ac_n "checking size of long long""... $ac_c" 1>&6 -echo "configure:3991: checking size of long long" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -4001,7 +4000,7 @@ exit(0); } EOF -if { (eval echo configure:4005: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:4004: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_long_long=`cat conftestval` else @@ -4023,10 +4022,10 @@ echo $ac_n "checking size of void *""... $ac_c" 1>&6 -echo "configure:4027: checking size of void *" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main() @@ -4037,7 +4036,7 @@ exit(0); } EOF -if { (eval echo configure:4041: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:4040: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_sizeof_void_p=`cat conftestval` else @@ -4060,7 +4059,7 @@ echo $ac_n "checking for long file names""... $ac_c" 1>&6 -echo "configure:4064: checking for long file names" >&5 +echo "configure:4063: checking for long file names" >&5 ac_cv_sys_long_file_names=yes # Test for long file names in all the places we know might matter: @@ -4107,12 +4106,12 @@ echo $ac_n "checking for sin in -lm""... $ac_c" 1>&6 -echo "configure:4111: checking for sin in -lm" >&5 +echo "configure:4110: checking for sin in -lm" >&5 ac_lib_var=`echo m'_'sin | sed 'y%./+-%__p_%'` xe_check_libs=" -lm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4126: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4165,14 +4164,14 @@ cat > conftest.$ac_ext < int main() { return atanh(1.0) + asinh(1.0) + acosh(1.0); ; return 0; } EOF -if { (eval echo configure:4176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4175: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_INVERSE_HYPERBOLIC @@ -4189,7 +4188,7 @@ rm -f conftest* echo "checking type of mail spool file locking" 1>&6 -echo "configure:4193: checking type of mail spool file locking" >&5 +echo "configure:4192: checking type of mail spool file locking" >&5 test -z "$mail_locking" -a "$mail_use_flock" = "yes" && mail_locking=flock test -z "$mail_locking" -a "$mail_use_lockf" = "yes" && mail_locking=lockf if test "$mail_locking" = "lockf"; then { test "$extra_verbose" = "yes" && cat << \EOF @@ -4213,12 +4212,12 @@ echo $ac_n "checking for kstat_open in -lkstat""... $ac_c" 1>&6 -echo "configure:4217: checking for kstat_open in -lkstat" >&5 +echo "configure:4216: checking for kstat_open in -lkstat" >&5 ac_lib_var=`echo kstat'_'kstat_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lkstat " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4263,12 +4262,12 @@ echo $ac_n "checking for kvm_read in -lkvm""... $ac_c" 1>&6 -echo "configure:4267: checking for kvm_read in -lkvm" >&5 +echo "configure:4266: checking for kvm_read in -lkvm" >&5 ac_lib_var=`echo kvm'_'kvm_read | sed 'y%./+-%__p_%'` xe_check_libs=" -lkvm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4282: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4314,12 +4313,12 @@ case "$opsys" in decosf*) echo $ac_n "checking for cma_open in -lpthreads""... $ac_c" 1>&6 -echo "configure:4318: checking for cma_open in -lpthreads" >&5 +echo "configure:4317: checking for cma_open in -lpthreads" >&5 ac_lib_var=`echo pthreads'_'cma_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lpthreads " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4333: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4366,7 +4365,7 @@ esac echo $ac_n "checking whether the -xildoff compiler flag is required""... $ac_c" 1>&6 -echo "configure:4370: checking whether the -xildoff compiler flag is required" >&5 +echo "configure:4369: checking whether the -xildoff compiler flag is required" >&5 if ${CC-cc} '-###' -xildon no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then if ${CC-cc} '-###' -xildoff no_such_file.c 2>&1 | grep '^[^ ]*/ild ' > /dev/null ; then echo "$ac_t""no" 1>&6; @@ -4377,7 +4376,7 @@ if test "$opsys" = "sol2" && test "$OS_RELEASE" -ge 56; then echo $ac_n "checking for \"-z ignore\" linker flag""... $ac_c" 1>&6 -echo "configure:4381: checking for \"-z ignore\" linker flag" >&5 +echo "configure:4380: checking for \"-z ignore\" linker flag" >&5 case "`ld -h 2>&1`" in *-z\ ignore\|record* ) echo "$ac_t""yes" 1>&6 ld_switch_site="-z ignore $ld_switch_site" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-z ignore\" to \$ld_switch_site"; fi ;; @@ -4387,7 +4386,7 @@ echo "checking "for specified window system"" 1>&6 -echo "configure:4391: checking "for specified window system"" >&5 +echo "configure:4390: checking "for specified window system"" >&5 if test "$with_x11" != "no"; then test "$x_includes $x_libraries" != "NONE NONE" && \ @@ -4420,7 +4419,7 @@ # Uses ac_ vars as temps to allow command line to override cache and checks. # --without-x overrides everything else, but does not touch the cache. echo $ac_n "checking for X""... $ac_c" 1>&6 -echo "configure:4424: checking for X" >&5 +echo "configure:4423: checking for X" >&5 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then @@ -4480,12 +4479,12 @@ # First, try using that file with no special directory specified. cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:4489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:4488: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -4554,14 +4553,14 @@ ac_save_LIBS="$LIBS" LIBS="-l$x_direct_test_library $LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4564: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* LIBS="$ac_save_LIBS" # We can link X programs with no special library path. @@ -4670,17 +4669,17 @@ case "`(uname -sr) 2>/dev/null`" in "SunOS 5"*) echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6 -echo "configure:4674: checking whether -R must be followed by a space" >&5 +echo "configure:4673: checking whether -R must be followed by a space" >&5 ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +#line 4676 "configure" +#include "confdefs.h" + +int main() { + +; return 0; } +EOF +if { (eval echo configure:4683: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_nospace=yes else @@ -4696,14 +4695,14 @@ else LIBS="$ac_xsave_LIBS -R $x_libraries" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +#line 4699 "configure" +#include "confdefs.h" + +int main() { + +; return 0; } +EOF +if { (eval echo configure:4706: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_R_space=yes else @@ -4739,12 +4738,12 @@ else echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6 -echo "configure:4743: checking for dnet_ntoa in -ldnet" >&5 +echo "configure:4742: checking for dnet_ntoa in -ldnet" >&5 ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4779,12 +4778,12 @@ if test $ac_cv_lib_dnet_dnet_ntoa = no; then echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6 -echo "configure:4783: checking for dnet_ntoa in -ldnet_stub" >&5 +echo "configure:4782: checking for dnet_ntoa in -ldnet_stub" >&5 ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'` xe_check_libs=" -ldnet_stub " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4824,10 +4823,10 @@ # 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4853: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_gethostbyname=yes" else @@ -4871,12 +4870,12 @@ if test $ac_cv_func_gethostbyname = no; then echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6 -echo "configure:4875: checking for gethostbyname in -lnsl" >&5 +echo "configure:4874: checking for gethostbyname in -lnsl" >&5 ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'` xe_check_libs=" -lnsl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -4917,10 +4916,10 @@ # -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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4946: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_connect=yes" else @@ -4966,12 +4965,12 @@ xe_msg_checking="for connect in -lsocket" test -n "$X_EXTRA_LIBS" && xe_msg_checking="$xe_msg_checking using extra libs $X_EXTRA_LIBS" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:4970: checking "$xe_msg_checking"" >&5 +echo "configure:4969: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocket $X_EXTRA_LIBS" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:4985: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5006,10 +5005,10 @@ # 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5035: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_remove=yes" else @@ -5053,12 +5052,12 @@ if test $ac_cv_func_remove = no; then echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6 -echo "configure:5057: checking for remove in -lposix" >&5 +echo "configure:5056: checking for remove in -lposix" >&5 ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'` xe_check_libs=" -lposix " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5072: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5093,10 +5092,10 @@ # 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5122: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_shmat=yes" else @@ -5140,12 +5139,12 @@ if test $ac_cv_func_shmat = no; then echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6 -echo "configure:5144: checking for shmat in -lipc" >&5 +echo "configure:5143: checking for shmat in -lipc" >&5 ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'` xe_check_libs=" -lipc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5159: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5190,12 +5189,12 @@ # --interran@uluru.Stanford.EDU, kb@cs.umb.edu. echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6 -echo "configure:5194: checking for IceConnectionNumber in -lICE" >&5 +echo "configure:5193: checking for IceConnectionNumber in -lICE" >&5 ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'` xe_check_libs=" -lICE " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5209: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5334,8 +5333,8 @@ set x $ld_switch_run; shift; ld_switch_run="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;; + -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;; -Xlinker* ) ;; * ) ld_switch_run="$ld_switch_run -Xlinker $1" ;; esac @@ -5375,7 +5374,7 @@ echo "checking for X defines extracted by xmkmf" 1>&6 -echo "configure:5379: checking for X defines extracted by xmkmf" >&5 +echo "configure:5378: checking for X defines extracted by xmkmf" >&5 rm -fr conftestdir if mkdir conftestdir; then cd conftestdir @@ -5407,15 +5406,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5419: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5418: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5439,12 +5438,12 @@ echo $ac_n "checking for XOpenDisplay in -lX11""... $ac_c" 1>&6 -echo "configure:5443: checking for XOpenDisplay in -lX11" >&5 +echo "configure:5442: checking for XOpenDisplay in -lX11" >&5 ac_lib_var=`echo X11'_'XOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5458: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5480,12 +5479,12 @@ xe_msg_checking="for XGetFontProperty in -lX11" test -n "-b i486-linuxaout" && xe_msg_checking="$xe_msg_checking using extra libs -b i486-linuxaout" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:5484: checking "$xe_msg_checking"" >&5 +echo "configure:5483: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo X11'_'XGetFontProperty | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 -b i486-linuxaout" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5499: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5523,12 +5522,12 @@ echo $ac_n "checking for XShapeSelectInput in -lXext""... $ac_c" 1>&6 -echo "configure:5527: checking for XShapeSelectInput in -lXext" >&5 +echo "configure:5526: checking for XShapeSelectInput in -lXext" >&5 ac_lib_var=`echo Xext'_'XShapeSelectInput | sed 'y%./+-%__p_%'` xe_check_libs=" -lXext " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5542: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5562,12 +5561,12 @@ echo $ac_n "checking for XtOpenDisplay in -lXt""... $ac_c" 1>&6 -echo "configure:5566: checking for XtOpenDisplay in -lXt" >&5 +echo "configure:5565: checking for XtOpenDisplay in -lXt" >&5 ac_lib_var=`echo Xt'_'XtOpenDisplay | sed 'y%./+-%__p_%'` xe_check_libs=" -lXt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5581: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5601,14 +5600,14 @@ echo $ac_n "checking the version of X11 being used""... $ac_c" 1>&6 -echo "configure:5605: checking the version of X11 being used" >&5 +echo "configure:5604: checking the version of X11 being used" >&5 cat > conftest.$ac_ext < int main(int c, char *v[]) { return c>1 ? XlibSpecificationRelease : 0; } EOF -if { (eval echo configure:5612: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:5611: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ./conftest foobar; x11_release=$? else @@ -5633,15 +5632,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5644: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -5672,7 +5671,7 @@ echo $ac_n "checking for XFree86""... $ac_c" 1>&6 -echo "configure:5676: checking for XFree86" >&5 +echo "configure:5675: checking for XFree86" >&5 if test -d "/usr/X386/include" -o \ -f "/etc/XF86Config" -o \ -f "/etc/X11/XF86Config" -o \ @@ -5692,12 +5691,12 @@ test -z "$with_xmu" && { echo $ac_n "checking for XmuReadBitmapDataFromFile in -lXmu""... $ac_c" 1>&6 -echo "configure:5696: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 +echo "configure:5695: checking for XmuReadBitmapDataFromFile in -lXmu" >&5 ac_lib_var=`echo Xmu'_'XmuReadBitmapDataFromFile | sed 'y%./+-%__p_%'` xe_check_libs=" -lXmu " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5747,19 +5746,19 @@ echo $ac_n "checking for main in -lXbsd""... $ac_c" 1>&6 -echo "configure:5751: checking for main in -lXbsd" >&5 +echo "configure:5750: checking for main in -lXbsd" >&5 ac_lib_var=`echo Xbsd'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lXbsd " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5762: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5796,22 +5795,22 @@ fi if test "$with_msw" != "no"; then echo "checking for MS-Windows" 1>&6 -echo "configure:5800: checking for MS-Windows" >&5 +echo "configure:5799: checking for MS-Windows" >&5 echo $ac_n "checking for main in -lgdi32""... $ac_c" 1>&6 -echo "configure:5803: checking for main in -lgdi32" >&5 +echo "configure:5802: checking for main in -lgdi32" >&5 ac_lib_var=`echo gdi32'_'main | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdi32 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:5814: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -5862,7 +5861,7 @@ echo " xemacs will be linked with \"dialog-msw.o\"" fi else - test "$with_scrollbars" != "no" && extra_objs="$extra_objs scrollbar-msw.o" && if test "$extra_verbose" = "yes"; then + test "$with_scrollbars" != "no" && extra_objs="$extra_objs scrollbar-msw.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"scrollbar-msw.o\"" fi test "$with_menubars" != "no" && extra_objs="$extra_objs menubar-msw.o" && if test "$extra_verbose" = "yes"; then @@ -5871,17 +5870,17 @@ test "$with_toolbars" != "no" && extra_objs="$extra_objs toolbar-msw.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"toolbar-msw.o\"" fi - test "$with_dialogs" != "no" && extra_objs="$extra_objs dialog-msw.o" && if test "$extra_verbose" = "yes"; then + test "$with_dialogs" != "no" && extra_objs="$extra_objs dialog-msw.o" && if test "$extra_verbose" = "yes"; then echo " xemacs will be linked with \"dialog-msw.o\"" fi fi cat > conftest.$ac_ext < int main() { return (open("/dev/windows", O_RDONLY, 0) > 0)? 0 : 1; } EOF -if { (eval echo configure:5885: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:5884: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_MSG_SELECT @@ -5960,7 +5959,7 @@ esac echo "checking for session-management option" 1>&6 -echo "configure:5964: checking for session-management option" >&5; +echo "configure:5963: checking for session-management option" >&5; if test "$with_session" != "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SESSION @@ -5975,15 +5974,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:5987: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:5986: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6006,12 +6005,12 @@ } test -z "$with_xauth" && { echo $ac_n "checking for XauGetAuthByAddr in -lXau""... $ac_c" 1>&6 -echo "configure:6010: checking for XauGetAuthByAddr in -lXau" >&5 +echo "configure:6009: checking for XauGetAuthByAddr in -lXau" >&5 ac_lib_var=`echo Xau'_'XauGetAuthByAddr | sed 'y%./+-%__p_%'` xe_check_libs=" -lXau " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6025: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6067,15 +6066,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6079: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6078: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6111,12 +6110,12 @@ xe_msg_checking="for tt_message_create in -ltt" test -n "$extra_libs" && xe_msg_checking="$xe_msg_checking using extra libs $extra_libs" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6115: checking "$xe_msg_checking"" >&5 +echo "configure:6114: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo tt'_'tt_message_create | sed 'y%./+-%__p_%'` xe_check_libs=" -ltt $extra_libs" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6130: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6184,15 +6183,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6196: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6195: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6215,12 +6214,12 @@ } test -z "$with_cde" && { echo $ac_n "checking for DtDndDragStart in -lDtSvc""... $ac_c" 1>&6 -echo "configure:6219: checking for DtDndDragStart in -lDtSvc" >&5 +echo "configure:6218: checking for DtDndDragStart in -lDtSvc" >&5 ac_lib_var=`echo DtSvc'_'DtDndDragStart | sed 'y%./+-%__p_%'` xe_check_libs=" -lDtSvc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6234: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6300,7 +6299,7 @@ fi echo $ac_n "checking if drag and drop API is needed""... $ac_c" 1>&6 -echo "configure:6304: checking if drag and drop API is needed" >&5 +echo "configure:6303: checking if drag and drop API is needed" >&5 if test "$with_dragndrop" != "no" ; then if test -n "$dragndrop_proto" ; then with_dragndrop=yes @@ -6321,18 +6320,18 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6336: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6335: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6355,15 +6354,15 @@ } 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6367: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6366: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6389,12 +6388,12 @@ xe_msg_checking="for ldap_open in -lldap" test -n "-llber" && xe_msg_checking="$xe_msg_checking using extra libs -llber" echo $ac_n "checking "$xe_msg_checking"""... $ac_c" 1>&6 -echo "configure:6393: checking "$xe_msg_checking"" >&5 +echo "configure:6392: checking "$xe_msg_checking"" >&5 ac_lib_var=`echo ldap'_'ldap_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lldap -llber" cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6428,12 +6427,12 @@ } test "$with_umich_ldap" = "no" && { echo $ac_n "checking for ldap_set_option in -lldap10""... $ac_c" 1>&6 -echo "configure:6432: checking for ldap_set_option in -lldap10" >&5 +echo "configure:6431: checking for ldap_set_option in -lldap10" >&5 ac_lib_var=`echo ldap10'_'ldap_set_option | sed 'y%./+-%__p_%'` xe_check_libs=" -lldap10 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6447: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6508,15 +6507,15 @@ if test "$window_system" != "none"; then echo "checking for graphics libraries" 1>&6 -echo "configure:6512: checking for graphics libraries" >&5 +echo "configure:6511: checking for graphics libraries" >&5 xpm_problem="" if test -z "$with_xpm"; then echo $ac_n "checking for Xpm - no older than 3.4f""... $ac_c" 1>&6 -echo "configure:6517: checking for Xpm - no older than 3.4f" >&5 +echo "configure:6516: checking for Xpm - no older than 3.4f" >&5 xe_check_libs=-lXpm cat > conftest.$ac_ext < int main(int c, char **v) { @@ -6524,7 +6523,7 @@ XpmIncludeVersion != XpmLibraryVersion() ? 1 : XpmIncludeVersion < 30406 ? 2 : 0 ;} EOF -if { (eval echo configure:6528: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:6527: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ./conftest dummy_arg; xpm_status=$?; if test "$xpm_status" = "0"; then @@ -6566,17 +6565,17 @@ libs_x="-lXpm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXpm\" to \$libs_x"; fi echo $ac_n "checking for \"FOR_MSW\" xpm""... $ac_c" 1>&6 -echo "configure:6570: checking for \"FOR_MSW\" xpm" >&5 +echo "configure:6569: checking for \"FOR_MSW\" xpm" >&5 xe_check_libs=-lXpm cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6579: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* xpm_for_msw=no else @@ -6618,12 +6617,12 @@ if test "$with_png $with_tiff" != "no no"; then echo $ac_n "checking for inflate in -lc""... $ac_c" 1>&6 -echo "configure:6622: checking for inflate in -lc" >&5 +echo "configure:6621: checking for inflate in -lc" >&5 ac_lib_var=`echo c'_'inflate | sed 'y%./+-%__p_%'` xe_check_libs=" -lc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6637: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6653,12 +6652,12 @@ echo "$ac_t""no" 1>&6 echo $ac_n "checking for inflate in -lz""... $ac_c" 1>&6 -echo "configure:6657: checking for inflate in -lz" >&5 +echo "configure:6656: checking for inflate in -lz" >&5 ac_lib_var=`echo z'_'inflate | sed 'y%./+-%__p_%'` xe_check_libs=" -lz " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6672: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6688,12 +6687,12 @@ echo "$ac_t""no" 1>&6 echo $ac_n "checking for inflate in -lgz""... $ac_c" 1>&6 -echo "configure:6692: checking for inflate in -lgz" >&5 +echo "configure:6691: checking for inflate in -lgz" >&5 ac_lib_var=`echo gz'_'inflate | sed 'y%./+-%__p_%'` xe_check_libs=" -lgz " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6707: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6734,15 +6733,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6746: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6745: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6765,12 +6764,12 @@ } test -z "$with_jpeg" && { echo $ac_n "checking for jpeg_destroy_decompress in -ljpeg""... $ac_c" 1>&6 -echo "configure:6769: checking for jpeg_destroy_decompress in -ljpeg" >&5 +echo "configure:6768: checking for jpeg_destroy_decompress in -ljpeg" >&5 ac_lib_var=`echo jpeg'_'jpeg_destroy_decompress | sed 'y%./+-%__p_%'` xe_check_libs=" -ljpeg " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6784: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6817,10 +6816,10 @@ png_problem="" test -z "$with_png" && { echo $ac_n "checking for pow""... $ac_c" 1>&6 -echo "configure:6821: checking for pow" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6846: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_pow=yes" else @@ -6864,15 +6863,15 @@ } 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:6876: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6875: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -6895,12 +6894,12 @@ } test -z "$with_png" && { echo $ac_n "checking for png_read_image in -lpng""... $ac_c" 1>&6 -echo "configure:6899: checking for png_read_image in -lpng" >&5 +echo "configure:6898: checking for png_read_image in -lpng" >&5 ac_lib_var=`echo png'_'png_read_image | sed 'y%./+-%__p_%'` xe_check_libs=" -lpng " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:6914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -6934,10 +6933,10 @@ } if test -z "$with_png"; then echo $ac_n "checking for workable png version information""... $ac_c" 1>&6 -echo "configure:6938: checking for workable png version information" >&5 +echo "configure:6937: checking for workable png version information" >&5 xe_check_libs="-lpng -lz" cat > conftest.$ac_ext < int main(int c, char **v) { @@ -6945,7 +6944,7 @@ if (strcmp(png_libpng_ver, PNG_LIBPNG_VER_STRING) != 0) return 1; return (PNG_LIBPNG_VER < 10002) ? 2 : 0 ;} EOF -if { (eval echo configure:6949: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:6948: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ./conftest dummy_arg; png_status=$?; if test "$png_status" = "0"; then @@ -6988,15 +6987,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7000: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:6999: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7019,12 +7018,12 @@ } test -z "$with_tiff" && { echo $ac_n "checking for TIFFClientOpen in -ltiff""... $ac_c" 1>&6 -echo "configure:7023: checking for TIFFClientOpen in -ltiff" >&5 +echo "configure:7022: checking for TIFFClientOpen in -ltiff" >&5 ac_lib_var=`echo tiff'_'TIFFClientOpen | sed 'y%./+-%__p_%'` xe_check_libs=" -ltiff " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7038: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7074,19 +7073,19 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7090: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7109,12 +7108,12 @@ } test -z "$with_xface" && { echo $ac_n "checking for UnGenFace in -lcompface""... $ac_c" 1>&6 -echo "configure:7113: checking for UnGenFace in -lcompface" >&5 +echo "configure:7112: checking for UnGenFace in -lcompface" >&5 ac_lib_var=`echo compface'_'UnGenFace | sed 'y%./+-%__p_%'` xe_check_libs=" -lcompface " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7128: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7161,12 +7160,12 @@ echo $ac_n "checking for XawScrollbarSetThumb in -lXaw""... $ac_c" 1>&6 -echo "configure:7165: checking for XawScrollbarSetThumb in -lXaw" >&5 +echo "configure:7164: checking for XawScrollbarSetThumb in -lXaw" >&5 ac_lib_var=`echo Xaw'_'XawScrollbarSetThumb | sed 'y%./+-%__p_%'` xe_check_libs=" -lXaw " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7180: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7201,15 +7200,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7213: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7212: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7226,12 +7225,12 @@ echo "$ac_t""yes" 1>&6 echo $ac_n "checking for XmStringFree in -lXm""... $ac_c" 1>&6 -echo "configure:7230: checking for XmStringFree in -lXm" >&5 +echo "configure:7229: checking for XmStringFree in -lXm" >&5 ac_lib_var=`echo Xm'_'XmStringFree | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7245: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7271,9 +7270,9 @@ if test "$have_motif" = "yes"; then echo $ac_n "checking for Lesstif""... $ac_c" 1>&6 -echo "configure:7275: checking for Lesstif" >&5 +echo "configure:7274: checking for Lesstif" >&5 cat > conftest.$ac_ext < #ifdef LESSTIF_VERSION @@ -7557,7 +7556,7 @@ if test "$with_mule" = "yes" ; then echo "checking for Mule-related features" 1>&6 -echo "configure:7561: checking for Mule-related features" >&5 +echo "configure:7560: checking for Mule-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining MULE EOF @@ -7582,15 +7581,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7594: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7593: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7621,12 +7620,12 @@ echo $ac_n "checking for strerror in -lintl""... $ac_c" 1>&6 -echo "configure:7625: checking for strerror in -lintl" >&5 +echo "configure:7624: checking for strerror in -lintl" >&5 ac_lib_var=`echo intl'_'strerror | sed 'y%./+-%__p_%'` xe_check_libs=" -lintl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7640: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7670,19 +7669,19 @@ echo "checking for Mule input methods" 1>&6 -echo "configure:7674: checking for Mule input methods" >&5 +echo "configure:7673: checking for Mule input methods" >&5 case "$with_xim" in "" | "yes" ) echo "checking for XIM" 1>&6 -echo "configure:7677: checking for XIM" >&5 +echo "configure:7676: checking for XIM" >&5 if test "$have_lesstif" = "yes"; then with_xim=xlib else echo $ac_n "checking for XmImMbLookupString in -lXm""... $ac_c" 1>&6 -echo "configure:7681: checking for XmImMbLookupString in -lXm" >&5 +echo "configure:7680: checking for XmImMbLookupString in -lXm" >&5 ac_lib_var=`echo Xm'_'XmImMbLookupString | sed 'y%./+-%__p_%'` xe_check_libs=" -lXm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7696: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7759,15 +7758,15 @@ if test "$with_xfs" = "yes" ; then echo "checking for XFontSet" 1>&6 -echo "configure:7763: checking for XFontSet" >&5 +echo "configure:7762: checking for XFontSet" >&5 echo $ac_n "checking for XmbDrawString in -lX11""... $ac_c" 1>&6 -echo "configure:7766: checking for XmbDrawString in -lX11" >&5 +echo "configure:7765: checking for XmbDrawString in -lX11" >&5 ac_lib_var=`echo X11'_'XmbDrawString | sed 'y%./+-%__p_%'` xe_check_libs=" -lX11 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7781: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7818,15 +7817,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:7830: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:7829: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -7851,10 +7850,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7880: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -7906,12 +7905,12 @@ test "$ac_cv_func_crypt" != "yes" && { echo $ac_n "checking for crypt in -lcrypt""... $ac_c" 1>&6 -echo "configure:7910: checking for crypt in -lcrypt" >&5 +echo "configure:7909: checking for crypt in -lcrypt" >&5 ac_lib_var=`echo crypt'_'crypt | sed 'y%./+-%__p_%'` xe_check_libs=" -lcrypt " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7957,12 +7956,12 @@ if test -z "$with_wnn" -o "$with_wnn" = "yes"; then echo $ac_n "checking for jl_dic_list_e in -lwnn""... $ac_c" 1>&6 -echo "configure:7961: checking for jl_dic_list_e in -lwnn" >&5 +echo "configure:7960: checking for jl_dic_list_e in -lwnn" >&5 ac_lib_var=`echo wnn'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:7976: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -7991,12 +7990,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for jl_dic_list_e in -lwnn4""... $ac_c" 1>&6 -echo "configure:7995: checking for jl_dic_list_e in -lwnn4" >&5 +echo "configure:7994: checking for jl_dic_list_e in -lwnn4" >&5 ac_lib_var=`echo wnn4'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn4 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8010: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8025,12 +8024,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for jl_dic_list_e in -lwnn6""... $ac_c" 1>&6 -echo "configure:8029: checking for jl_dic_list_e in -lwnn6" >&5 +echo "configure:8028: checking for jl_dic_list_e in -lwnn6" >&5 ac_lib_var=`echo wnn6'_'jl_dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn6 " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8044: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8059,12 +8058,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for dic_list_e in -lwnn6_fromsrc""... $ac_c" 1>&6 -echo "configure:8063: checking for dic_list_e in -lwnn6_fromsrc" >&5 +echo "configure:8062: checking for dic_list_e in -lwnn6_fromsrc" >&5 ac_lib_var=`echo wnn6_fromsrc'_'dic_list_e | sed 'y%./+-%__p_%'` xe_check_libs=" -lwnn6_fromsrc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8078: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8123,12 +8122,12 @@ if test "$with_wnn6" != "no"; then echo $ac_n "checking for jl_fi_dic_list in -l$libwnn""... $ac_c" 1>&6 -echo "configure:8127: checking for jl_fi_dic_list in -l$libwnn" >&5 +echo "configure:8126: checking for jl_fi_dic_list in -l$libwnn" >&5 ac_lib_var=`echo $libwnn'_'jl_fi_dic_list | sed 'y%./+-%__p_%'` xe_check_libs=" -l$libwnn " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8142: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8174,15 +8173,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8186: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8185: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8209,15 +8208,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8221: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8220: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8245,15 +8244,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:8257: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:8256: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -8276,12 +8275,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for RkBgnBun in -lRKC""... $ac_c" 1>&6 -echo "configure:8280: checking for RkBgnBun in -lRKC" >&5 +echo "configure:8279: checking for RkBgnBun in -lRKC" >&5 ac_lib_var=`echo RKC'_'RkBgnBun | sed 'y%./+-%__p_%'` xe_check_libs=" -lRKC " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8295: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8315,12 +8314,12 @@ } test -z "$with_canna" && { echo $ac_n "checking for jrKanjiControl in -lcanna""... $ac_c" 1>&6 -echo "configure:8319: checking for jrKanjiControl in -lcanna" >&5 +echo "configure:8318: checking for jrKanjiControl in -lcanna" >&5 ac_lib_var=`echo canna'_'jrKanjiControl | sed 'y%./+-%__p_%'` xe_check_libs=" -lcanna " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8334: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8380,12 +8379,12 @@ libs_x="-lXm $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-lXm\" to \$libs_x"; fi echo $ac_n "checking for layout_object_getvalue in -li18n""... $ac_c" 1>&6 -echo "configure:8384: checking for layout_object_getvalue in -li18n" >&5 +echo "configure:8383: checking for layout_object_getvalue in -li18n" >&5 ac_lib_var=`echo i18n'_'layout_object_getvalue | sed 'y%./+-%__p_%'` xe_check_libs=" -li18n " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8399: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -8465,8 +8464,8 @@ set x $ld_switch_run; shift; ld_switch_run="" while test -n "$1"; do case $1 in - -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; - -L* | -l* | -u* | -Wl* ) ld_switch_run="$ld_switch_run $1" ;; + -L | -l | -u ) ld_switch_run="$ld_switch_run $1 $2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) ld_switch_run="$ld_switch_run $1" ;; -Xlinker* ) ;; * ) ld_switch_run="$ld_switch_run -Xlinker $1" ;; esac @@ -8482,10 +8481,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8511: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8549,10 +8548,10 @@ * ) 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8578: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -8609,16 +8608,16 @@ esac echo $ac_n "checking whether netdb declares h_errno""... $ac_c" 1>&6 -echo "configure:8613: checking whether netdb declares h_errno" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { return h_errno; ; return 0; } EOF -if { (eval echo configure:8622: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8621: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -8638,16 +8637,16 @@ rm -f conftest* echo $ac_n "checking for sigsetjmp""... $ac_c" 1>&6 -echo "configure:8642: checking for sigsetjmp" >&5 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext < int main() { sigjmp_buf bar; sigsetjmp (bar, 0); ; return 0; } EOF -if { (eval echo configure:8651: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:8650: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* echo "$ac_t""yes" 1>&6 { test "$extra_verbose" = "yes" && cat << \EOF @@ -8667,11 +8666,11 @@ rm -f conftest* echo $ac_n "checking whether localtime caches TZ""... $ac_c" 1>&6 -echo "configure:8671: checking whether localtime caches TZ" >&5 +echo "configure:8670: checking whether localtime caches TZ" >&5 if test "$ac_cv_func_tzset" = "yes"; then cat > conftest.$ac_ext < #if STDC_HEADERS @@ -8706,7 +8705,7 @@ exit (0); } EOF -if { (eval echo configure:8710: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:8709: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then emacs_cv_localtime_cache=no else @@ -8736,9 +8735,9 @@ 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 -cat > conftest.$ac_ext <&5 +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8763: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""two" 1>&6 else @@ -8782,19 +8781,19 @@ echo $ac_n "checking for inline""... $ac_c" 1>&6 -echo "configure:8786: checking for inline" >&5 +echo "configure:8785: checking for inline" >&5 ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:8797: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* ac_cv_c_inline=$ac_kw; break else @@ -8844,17 +8843,17 @@ # 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < int main() { char *p = alloca(2 * sizeof(int)); ; return 0; } EOF -if { (eval echo configure:8858: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8857: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_header_alloca_h=yes else @@ -8878,10 +8877,10 @@ fi echo $ac_n "checking for alloca""... $ac_c" 1>&6 -echo "configure:8882: checking for alloca" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8907: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* ac_cv_func_alloca_works=yes else @@ -8943,10 +8942,10 @@ echo $ac_n "checking whether alloca needs Cray hooks""... $ac_c" 1>&6 -echo "configure:8947: checking whether alloca needs Cray hooks" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&6 -echo "configure:8974: checking for $ac_func" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:8999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -9026,10 +9025,10 @@ fi echo $ac_n "checking stack direction for C alloca""... $ac_c" 1>&6 -echo "configure:9030: checking stack direction for C alloca" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9051: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_c_stack_direction=1 else @@ -9077,15 +9076,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9089: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9088: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9113,10 +9112,10 @@ fi echo $ac_n "checking for working vfork""... $ac_c" 1>&6 -echo "configure:9117: checking for working vfork" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < @@ -9211,7 +9210,7 @@ } } EOF -if { (eval echo configure:9215: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9214: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_vfork_works=yes else @@ -9237,10 +9236,10 @@ echo $ac_n "checking for working strcoll""... $ac_c" 1>&6 -echo "configure:9241: checking for working strcoll" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < main () @@ -9250,7 +9249,7 @@ strcoll ("123", "456") >= 0); } EOF -if { (eval echo configure:9254: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9253: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_strcoll_works=yes else @@ -9278,10 +9277,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9307: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -9332,10 +9331,10 @@ done echo $ac_n "checking whether getpgrp takes no argument""... $ac_c" 1>&6 -echo "configure:9336: checking whether getpgrp takes no argument" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9393: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_getpgrp_void=yes else @@ -9417,10 +9416,10 @@ echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:9421: checking for working mmap" >&5 +echo "configure:9420: checking for working mmap" >&5 case "$opsys" in ultrix* ) have_mmap=no ;; *) cat > conftest.$ac_ext < #include @@ -9453,7 +9452,7 @@ return 1; } EOF -if { (eval echo configure:9457: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9456: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then have_mmap=yes else @@ -9478,15 +9477,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9490: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9489: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9518,10 +9517,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9547: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -9572,10 +9571,10 @@ done echo $ac_n "checking for working mmap""... $ac_c" 1>&6 -echo "configure:9576: checking for working mmap" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:9718: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then ac_cv_func_mmap_fixed_mapped=yes else @@ -9753,15 +9752,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9765: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9764: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9804,15 +9803,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9816: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9815: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9844,10 +9843,10 @@ echo $ac_n "checking for socket""... $ac_c" 1>&6 -echo "configure:9848: checking for socket" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9873: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_socket=yes" else @@ -9885,15 +9884,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9897: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9896: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9910,15 +9909,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:9922: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:9921: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -9943,9 +9942,9 @@ } echo $ac_n "checking "for sun_len member in struct sockaddr_un"""... $ac_c" 1>&6 -echo "configure:9947: checking "for sun_len member in struct sockaddr_un"" >&5 +echo "configure:9946: checking "for sun_len member in struct sockaddr_un"" >&5 cat > conftest.$ac_ext < @@ -9956,7 +9955,7 @@ static struct sockaddr_un x; x.sun_len = 1; ; return 0; } EOF -if { (eval echo configure:9960: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9959: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_SOCKADDR_SUN_LEN @@ -9974,9 +9973,9 @@ fi rm -f conftest* echo $ac_n "checking "for ip_mreq struct in netinet/in.h"""... $ac_c" 1>&6 -echo "configure:9978: checking "for ip_mreq struct in netinet/in.h"" >&5 +echo "configure:9977: checking "for ip_mreq struct in netinet/in.h"" >&5 cat > conftest.$ac_ext < @@ -9986,7 +9985,7 @@ static struct ip_mreq x; ; return 0; } EOF -if { (eval echo configure:9990: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:9989: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* echo "$ac_t""yes" 1>&6; { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_MULTICAST @@ -10017,10 +10016,10 @@ echo $ac_n "checking for msgget""... $ac_c" 1>&6 -echo "configure:10021: checking for msgget" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10046: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_msgget=yes" else @@ -10058,15 +10057,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10070: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10069: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10083,15 +10082,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10095: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10094: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10129,15 +10128,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10141: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10140: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10164,15 +10163,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10176: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10175: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10205,15 +10204,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10217: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10216: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10243,7 +10242,7 @@ echo "checking "for sound support"" 1>&6 -echo "configure:10247: checking "for sound support"" >&5 +echo "configure:10246: checking "for sound support"" >&5 case "$with_sound" in native | both ) with_native_sound=yes;; nas | no ) with_native_sound=no;; @@ -10254,15 +10253,15 @@ if test -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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10266: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10265: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10310,12 +10309,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for ALopenport in -laudio""... $ac_c" 1>&6 -echo "configure:10314: checking for ALopenport in -laudio" >&5 +echo "configure:10313: checking for ALopenport in -laudio" >&5 ac_lib_var=`echo audio'_'ALopenport | sed 'y%./+-%__p_%'` xe_check_libs=" -laudio " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10329: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10357,12 +10356,12 @@ if test -z "$native_sound_lib"; then echo $ac_n "checking for AOpenAudio in -lAlib""... $ac_c" 1>&6 -echo "configure:10361: checking for AOpenAudio in -lAlib" >&5 +echo "configure:10360: checking for AOpenAudio in -lAlib" >&5 ac_lib_var=`echo Alib'_'AOpenAudio | sed 'y%./+-%__p_%'` xe_check_libs=" -lAlib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10376: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10411,15 +10410,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10423: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10422: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10489,7 +10488,7 @@ fi libs_x="-laudio $libs_x" && if test "$extra_verbose" = "yes"; then echo " Prepending \"-laudio\" to \$libs_x"; fi cat > conftest.$ac_ext < EOF @@ -10516,7 +10515,7 @@ if test "$with_tty" = "yes" ; then echo "checking for TTY-related features" 1>&6 -echo "configure:10520: checking for TTY-related features" >&5 +echo "configure:10519: checking for TTY-related features" >&5 { test "$extra_verbose" = "yes" && cat << \EOF Defining HAVE_TTY EOF @@ -10532,12 +10531,12 @@ if test -z "$with_ncurses"; then echo $ac_n "checking for tgetent in -lncurses""... $ac_c" 1>&6 -echo "configure:10536: checking for tgetent in -lncurses" >&5 +echo "configure:10535: checking for tgetent in -lncurses" >&5 ac_lib_var=`echo ncurses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lncurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10551: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10581,15 +10580,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10593: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10592: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10611,15 +10610,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10623: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10622: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10649,15 +10648,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10661: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10660: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10692,12 +10691,12 @@ for lib in curses termlib termcap; do echo $ac_n "checking for tgetent in -l$lib""... $ac_c" 1>&6 -echo "configure:10696: checking for tgetent in -l$lib" >&5 +echo "configure:10695: checking for tgetent in -l$lib" >&5 ac_lib_var=`echo $lib'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -l$lib " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10711: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10739,12 +10738,12 @@ else echo $ac_n "checking for tgetent in -lcurses""... $ac_c" 1>&6 -echo "configure:10743: checking for tgetent in -lcurses" >&5 +echo "configure:10742: checking for tgetent in -lcurses" >&5 ac_lib_var=`echo curses'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -lcurses " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10758: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10773,12 +10772,12 @@ else echo "$ac_t""no" 1>&6 echo $ac_n "checking for tgetent in -ltermcap""... $ac_c" 1>&6 -echo "configure:10777: checking for tgetent in -ltermcap" >&5 +echo "configure:10776: checking for tgetent in -ltermcap" >&5 ac_lib_var=`echo termcap'_'tgetent | sed 'y%./+-%__p_%'` xe_check_libs=" -ltermcap " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10792: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10837,15 +10836,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10849: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10848: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10868,12 +10867,12 @@ } test -z "$with_gpm" && { echo $ac_n "checking for Gpm_Open in -lgpm""... $ac_c" 1>&6 -echo "configure:10872: checking for Gpm_Open in -lgpm" >&5 +echo "configure:10871: checking for Gpm_Open in -lgpm" >&5 ac_lib_var=`echo gpm'_'Gpm_Open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgpm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10887: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -10933,22 +10932,22 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:10952: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:10951: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -10980,12 +10979,12 @@ if test "$have_ndbm_h" = "yes"; then echo $ac_n "checking for dbm_open in -lgdbm""... $ac_c" 1>&6 -echo "configure:10984: checking for dbm_open in -lgdbm" >&5 +echo "configure:10983: checking for dbm_open in -lgdbm" >&5 ac_lib_var=`echo gdbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -lgdbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:10999: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11019,10 +11018,10 @@ fi 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11048: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -11081,10 +11080,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11110: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_dbm_open=yes" else @@ -11128,12 +11127,12 @@ if test "$need_libdbm" != "no"; then echo $ac_n "checking for dbm_open in -ldbm""... $ac_c" 1>&6 -echo "configure:11132: checking for dbm_open in -ldbm" >&5 +echo "configure:11131: checking for dbm_open in -ldbm" >&5 ac_lib_var=`echo dbm'_'dbm_open | sed 'y%./+-%__p_%'` xe_check_libs=" -ldbm " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11147: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11181,10 +11180,10 @@ if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for Berkeley db.h""... $ac_c" 1>&6 -echo "configure:11185: checking for Berkeley db.h" >&5 +echo "configure:11184: checking for Berkeley db.h" >&5 for path in "db/db.h" "db.h"; do cat > conftest.$ac_ext <&5; (eval $ac_compile) 2>&5; }; then +if { (eval echo configure:11205: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then rm -rf conftest* db_h_path="$path"; break else @@ -11218,9 +11217,9 @@ if test "$with_database_berkdb" != "no"; then echo $ac_n "checking for Berkeley DB version""... $ac_c" 1>&6 -echo "configure:11222: checking for Berkeley DB version" >&5 +echo "configure:11221: checking for Berkeley DB version" >&5 cat > conftest.$ac_ext < #if DB_VERSION_MAJOR > 1 @@ -11239,10 +11238,10 @@ rm -f conftest* echo $ac_n "checking for $dbfunc""... $ac_c" 1>&6 -echo "configure:11243: checking for $dbfunc" >&5 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$dbfunc=yes" else @@ -11284,12 +11283,12 @@ echo $ac_n "checking for $dbfunc in -ldb""... $ac_c" 1>&6 -echo "configure:11288: checking for $dbfunc in -ldb" >&5 +echo "configure:11287: checking for $dbfunc in -ldb" >&5 ac_lib_var=`echo db'_'$dbfunc | sed 'y%./+-%__p_%'` xe_check_libs=" -ldb " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11303: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11364,12 +11363,12 @@ if test "$with_socks" = "yes"; then echo $ac_n "checking for SOCKSinit in -lsocks""... $ac_c" 1>&6 -echo "configure:11368: checking for SOCKSinit in -lsocks" >&5 +echo "configure:11367: checking for SOCKSinit in -lsocks" >&5 ac_lib_var=`echo socks'_'SOCKSinit | sed 'y%./+-%__p_%'` xe_check_libs=" -lsocks " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11383: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11439,15 +11438,15 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext < EOF ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:11451: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +{ (eval echo configure:11450: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* @@ -11478,12 +11477,12 @@ test -z "$with_shlib" && test ! -z "$have_dlfcn" && { echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 -echo "configure:11482: checking for dlopen in -ldl" >&5 +echo "configure:11481: checking for dlopen in -ldl" >&5 ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` xe_check_libs=" -ldl " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11497: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11523,12 +11522,12 @@ } test -z "$with_shlib" && test ! -z "$have_dlfcn" && { echo $ac_n "checking for _dlopen in -lc""... $ac_c" 1>&6 -echo "configure:11527: checking for _dlopen in -lc" >&5 +echo "configure:11526: checking for _dlopen in -lc" >&5 ac_lib_var=`echo c'_'_dlopen | sed 'y%./+-%__p_%'` xe_check_libs=" -lc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11542: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11568,12 +11567,12 @@ } test -z "$with_shlib" && test ! -z "$have_dlfcn" && { echo $ac_n "checking for dlopen in -lc""... $ac_c" 1>&6 -echo "configure:11572: checking for dlopen in -lc" >&5 +echo "configure:11571: checking for dlopen in -lc" >&5 ac_lib_var=`echo c'_'dlopen | sed 'y%./+-%__p_%'` xe_check_libs=" -lc " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11587: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11613,12 +11612,12 @@ } test -z "$with_shlib" && { echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6 -echo "configure:11617: checking for shl_load in -ldld" >&5 +echo "configure:11616: checking for shl_load in -ldld" >&5 ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'` xe_check_libs=" -ldld " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11632: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11658,12 +11657,12 @@ } test -z "$with_shlib" && { echo $ac_n "checking for dld_init in -ldld""... $ac_c" 1>&6 -echo "configure:11662: checking for dld_init in -ldld" >&5 +echo "configure:11661: checking for dld_init in -ldld" >&5 ac_lib_var=`echo dld'_'dld_init | sed 'y%./+-%__p_%'` xe_check_libs=" -ldld " cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11677: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_lib_$ac_lib_var=yes" else @@ -11724,7 +11723,7 @@ dll_oflags="-o " echo $ac_n "checking how to build a shared library""... $ac_c" 1>&6 -echo "configure:11728: checking how to build a shared library" >&5 +echo "configure:11727: checking how to build a shared library" >&5 case `uname -rs` in UNIX_SV*|UNIX_System_V*) dll_lflags="-G" @@ -11815,10 +11814,10 @@ 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 - -cat > conftest.$ac_ext <&5 + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then +if { (eval echo configure:11844: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else @@ -11877,11 +11876,11 @@ fi cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 +if { (eval echo configure:11884: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit $?) 2>&5 then : else @@ -11980,7 +11979,7 @@ MAKE_SUBDIR="$MAKE_SUBDIR src" && if test "$extra_verbose" = "yes"; then echo " Appending \"src\" to \$MAKE_SUBDIR"; fi -internal_makefile_list="Makefile" +internal_makefile_list="Makefile.in" SUBDIR_MAKEFILES='' test -d lock || mkdir lock for dir in $MAKE_SUBDIR; do @@ -12171,7 +12170,10 @@ -# The default is yes +: ${XEMACS_CC:=$CC} + + + if test "$with_site_lisp" = "no"; then { test "$extra_verbose" = "yes" && cat << \EOF Defining INHIBIT_SITE_LISP @@ -12331,14 +12333,6 @@ EOF } -test "$with_gnu_make" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF - Defining USE_GNU_MAKE -EOF -cat >> confdefs.h <<\EOF -#define USE_GNU_MAKE 1 -EOF -} - test "$no_doc_file" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF Defining NO_DOC_FILE EOF @@ -12347,6 +12341,14 @@ EOF } +test "$with_purify" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF + Defining PURIFY +EOF +cat >> confdefs.h <<\EOF +#define PURIFY 1 +EOF +} + test "$with_quantify" = "yes" && { test "$extra_verbose" = "yes" && cat << \EOF Defining QUANTIFY EOF @@ -12472,7 +12474,7 @@ native ) echo " Compiling in native sound support." ;; both ) echo " Compiling in both network and native sound support." ;; esac -test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously" +test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously." test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB." test "$with_database_dbm" = yes && echo " Compiling in support for DBM." @@ -12526,9 +12528,9 @@ test "$with_clash_detection" = yes && \ echo " Clash detection will use \"$lockdir\" for locking files." echo " movemail will use \"$mail_locking\" for locking mail spool files." -test "$with_pop" = yes && echo " Using POP for mail access" -test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" -test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" +test "$with_pop" = yes && echo " Using POP for mail access." +test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication." +test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host." test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$use_minimal_tagbits" = yes && echo " Using Lisp_Objects with minimal tagbits." test "$use_indexed_lrecord_implementation" = yes && echo " Using indexed lrecord implementation." @@ -12552,7 +12554,6 @@ echo '")' >> Installation.el - # Remove any trailing slashes in these variables. test -n "$prefix" && prefix=`echo '' "$prefix" | sed -e 's:^ ::' -e 's,\([^/]\)/*$,\1,'` @@ -12731,6 +12732,7 @@ s%@native_sound_lib@%$native_sound_lib%g s%@sound_cflags@%$sound_cflags%g s%@dynodump_arch@%$dynodump_arch%g +s%@XEMACS_CC@%$XEMACS_CC%g s%@internal_makefile_list@%$internal_makefile_list%g CEOF @@ -12942,14 +12944,12 @@ EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF -for dir in $MAKE_SUBDIR; do - echo creating $dir/Makefile +for dir in . $MAKE_SUBDIR; do ( cd $dir rm -f junk.c @@ -12961,26 +12961,45 @@ -e '/^#/ { p d -}' -e '/./ { +}' \ + -e '/./ { s/\([\"]\)/\\\1/g s/^/"/ s/$/"/ }' > junk.c; - $CPP -I. -I${top_srcdir}/src $CPPFLAGS junk.c > junk.cpp; - < junk.cpp \ - sed -e 's/^#.*//' \ - -e 's/^[ ][ ]*$//' \ - -e 's/^ / /' \ - | sed -n -e '/^..*$/p' \ - | sed '/^"/ { -s/\\\([\"]\)/\1/g -s/^[ ]*"// -s/"[ ]*$// -}' > Makefile.new + + + + echo creating $dir/Makefile +$CPP -I. -I${top_srcdir}/src junk.c \ + | sed -e 's/^\#.*//' \ + -e 's/^[ ][ ]*$//'\ + -e 's/^ / /' \ + | sed -n -e '/^..*$/p' \ + | sed '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ ]*\"// + s/\"[ ]*$// +}' > Makefile.new chmod 444 Makefile.new mv -f Makefile.new Makefile - rm -f junk.c junk.cpp -) + + echo creating $dir/GNUmakefile +$CPP -I. -I${top_srcdir}/src -DUSE_GNU_MAKE junk.c \ + | sed -e 's/^\#.*//' \ + -e 's/^[ ][ ]*$//'\ + -e 's/^ / /' \ + | sed -n -e '/^..*$/p' \ + | sed '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ ]*\"// + s/\"[ ]*$// +}' > Makefile.new + chmod 444 Makefile.new + mv -f Makefile.new GNUmakefile + + rm -f junk.c + ) done sed < config.status >> lib-src/config.values \ @@ -12995,4 +13014,3 @@ chmod +x $CONFIG_STATUS rm -fr confdefs* $ac_clean_files test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - diff -r 76b7d63099ad -r 8626e4521993 configure.in --- a/configure.in Mon Aug 13 11:06:08 2007 +0200 +++ b/configure.in Mon Aug 13 11:07:10 2007 +0200 @@ -229,6 +229,13 @@ [[$2]="[$1] $[$2]" && dnl if test "$extra_verbose" = "yes"; then echo " Prepending \"[$1]\" to \$[$2]"; fi]) +dnl XE_DIE(message) +define([XE_DIE], [{ echo $1 >&2; exit 1; }]) + +dnl XE_STRIP_4TH_COMPONENT(var) +dnl Changes i986-pc-linux-gnu to i986-pc-linux, as God (not RMS) intended. +define([XE_STRIP_4TH_COMPONENT], +[$1=`echo "$$1" | sed '[s/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/]'`]) dnl Initialize some variables set by options. dnl The variables have the same names as the options, with @@ -326,7 +333,6 @@ XE_APPEND(lib-src, MAKE_SUBDIR) XE_APPEND(lib-src, INSTALL_ARCH_DEP_SUBDIR) -dnl run_in_place='no' prefix='/usr/local' exec_prefix='${prefix}' bindir='${exec_prefix}/bin' @@ -453,13 +459,11 @@ case "$opt" in dnl Process (many) boolean options - run_in_place | \ - with_site_lisp | \ + with_site_lisp | \ with_x | \ with_x11 | \ with_msw | \ with_gcc | \ - with_gnu_make | \ dynamic | \ with_ncurses | \ with_dnet | \ @@ -476,19 +480,20 @@ with_tiff | \ with_session | \ with_xmu | \ + with_purify | \ with_quantify | \ with_toolbars | \ with_tty | \ with_xfs | \ with_i18n3 | \ with_mule | \ - with_file_coding | \ + with_file_coding| \ with_canna | \ with_wnn | \ with_wnn6 | \ with_workshop | \ with_sparcworks | \ - with_tooltalk | \ + with_tooltalk | \ with_ldap | \ with_pop | \ with_kerberos | \ @@ -499,14 +504,13 @@ verbose | \ extra_verbose | \ const_is_losing | \ - usage_tracking | \ - use_union_type | \ + usage_tracking | \ + use_union_type | \ debug | \ use_assertions | \ + gung_ho | \ use_minimal_tagbits | \ use_indexed_lrecord_implementation | \ - gung_ho | \ - use_assertions | \ memory_usage_stats | \ with_clash_detection | \ with_shlib | \ @@ -514,10 +518,10 @@ dnl Make sure the value given was either "yes" or "no". case "$val" in y | ye | yes ) val=yes ;; - n | no ) val=no ;; + n | no ) val=no ;; * ) USAGE_ERROR("The \`--$optname' option requires a boolean value: \`yes' or \`no'.") ;; esac - eval "$opt=\"$val\"" ;; + eval "$opt=\"$val\"" ;; dnl Options that take a user-supplied value, as in --puresize=8000000 @@ -531,7 +535,7 @@ ldflags | \ puresize | \ cache_file | \ - native_sound_lib | \ + native_sound_lib| \ site_lisp | \ x_includes | \ x_libraries | \ @@ -579,7 +583,7 @@ g | gn | gnu | gnud | gnudb | gnudbm ) with_database_gnudbm=yes ;; * ) USAGE_ERROR(["The \`--$optname' option value must be either \`no' or a comma-separated list - of one or more of \`berkdb', \`dbm', or \`gnudbm'."]) ;; + of one or more of \`berkdb' and either \`dbm' or \`gnudbm'."]) ;; esac done if test "$with_database_dbm" = "yes" -a \ @@ -618,17 +622,6 @@ eval "$opt=\"$val\"" ;; - dnl XFontSet support? - "with_xfs" ) - case "$val" in - y | ye | yes ) val=yes ;; - n | no | non | none ) val=no ;; - * ) USAGE_ERROR(["The \`--$optname' option must have one of these values: - \`yes', or \`no'."]) ;; - esac - eval "$opt=\"$val\"" - ;; - dnl Mail locking specification "mail_locking" ) case "$val" in @@ -699,7 +692,7 @@ dnl Has the user specified one of the path options? prefix | exec_prefix | bindir | datadir | statedir | libdir | \ mandir | infodir | infopath | lispdir | etcdir | lockdir | pkgdir | \ - archlibdir | docdir | package_path ) + archlibdir | docdir | package_path ) dnl If the value was omitted, get it from the next argument. if test "$valomitted" = "yes"; then if test "$#" = 0; then @@ -733,9 +726,10 @@ dnl Has the user asked for some help? "usage" | "help" ) ${PAGER-more} ${srcdir}/configure.usage; exit 0 ;; - dnl Has the user specified what toolkit to use for the menubars, - dnl scrollbar or dialogs? - "with_menubars" | "with_scrollbars" | "with_dialogs" ) + dnl Has the user specified the toolkit(s) to use for GUI elements? + "with_menubars" | \ + "with_scrollbars" | \ + "with_dialogs" ) case "$val" in l | lu | luc | luci | lucid ) val=lucid ;; m | mo | mot | moti | motif ) val=motif ;; @@ -748,7 +742,13 @@ eval "$opt=\"$val\"" ;; - dnl Fail on unrecognized arguments. + dnl Obsolete legacy argument? Warn, but otherwise ignore. + "run_in_place" | \ + "with_gnu_make" ) + AC_MSG_WARN([Obsolete option \`--$optname' ignored.]) + ;; + + dnl Unrecognized option? No mercy for user errors. * ) USAGE_ERROR("Unrecognized option: $arg") ;; esac @@ -757,7 +757,7 @@ dnl Assume anything with multiple hyphens is a configuration name. *-*-*) configuration="$arg" ;; - dnl Anything else is an error + dnl Unrecognized argument? No mercy for user errors. *) USAGE_ERROR("Unrecognized argument: $arg") ;; esac @@ -779,20 +779,16 @@ dnl --extra-verbose implies --verbose test "$extra_verbose" = "yes" && verbose=yes -dnl Allow use of either ":" or spaces for lists of directories -define(COLON_TO_SPACE, - [case "$[$1]" in *:* [)] [$1]="`echo '' $[$1] | sed -e 's/^ //' -e 's/:/ /g'`";; esac])dnl -COLON_TO_SPACE(site_includes) -COLON_TO_SPACE(site_libraries) -COLON_TO_SPACE(site_prefixes) -COLON_TO_SPACE(site_runtime_libraries) - dnl with_x is an obsolete synonym for with_x11 test -n "$with_x" && with_x11="$with_x" +dnl --with-quantify or --with-purify imply --use-system-malloc +if test "$with_purify" = "yes" -o "$with_quantify" = "yes"; then + test "$with_system_malloc" = "default" && with_system_malloc=yes +fi + dnl --gung-ho=val is a synonym for dnl --use-minimal-tagbits=val --use-indexed-lrecord-implementation=val - if test -n "$gung_ho"; then test -z "$use_minimal_tagbits" && use_minimal_tagbits="$gung_ho" test -z "$use_indexed_lrecord_implementation" && \ @@ -816,11 +812,6 @@ dnl CDE requires tooltalk XE_CHECK_FEATURE_DEPENDENCY(cde, tooltalk) -dnl Ignore useless run-in-place flag -if test "$run_in_place" = "yes"; then - AC_MSG_WARN("The --run-in-place option is ignored because it is unnecessary.") -fi - dnl Find the source directory. case "$srcdir" in @@ -856,13 +847,9 @@ dnl ########################################################################### if test -z "$configuration"; then - AC_MSG_CHECKING("host system type") - dnl Guess the configuration and remove 4th name component, if present. - if configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess | \ - sed '[s/^\([^-][^-]*-[^-][^-]*-[^-][^-]*\)-.*$/\1/]'` ; then - AC_MSG_RESULT($configuration) - else - AC_MSG_RESULT(unknown) + dnl Guess the configuration + configuration=`${CONFIG_SHELL-/bin/sh} $srcdir/config.guess` + if test -z "$configuration"; then USAGE_ERROR(["XEmacs has not been ported to this host type. Try explicitly specifying the CONFIGURATION when rerunning configure."]) fi @@ -985,12 +972,13 @@ dnl names of the m/*.h and s/*.h files we should use. dnl Canonicalize the configuration name. -AC_CHECKING("the configuration name") +AC_MSG_CHECKING("host system type") dnl allow -workshop suffix on configuration name internal_configuration=`echo $configuration | sed 's/-\(workshop\)//'` -if canonical=`$srcdir/config.sub "$internal_configuration"` ; then : ; else - exit $? -fi +canonical=`${CONFIG_SHELL-/bin/sh} $srcdir/config.sub "$internal_configuration"` +XE_STRIP_4TH_COMPONENT(configuration) +XE_STRIP_4TH_COMPONENT(canonical) +AC_MSG_RESULT($configuration) dnl If you add support for a new configuration, add code to this dnl switch statement to recognize your configuration name and select @@ -1033,6 +1021,8 @@ m68*-sony-* ) machine=news ;; mips-sony-* ) machine=news-risc ;; clipper-* ) machine=clipper ;; + arm-* ) machine=arm ;; + ns32k-* ) machine=ns32000 ;; esac dnl Straightforward OS determination @@ -1103,13 +1093,9 @@ dnl OpenBSD ports *-*-openbsd* ) case "${canonical}" in - alpha*-*-openbsd*) machine=alpha ;; i386-*-openbsd*) machine=intel386 ;; m68k-*-openbsd*) machine=hp9000s300 ;; mipsel-*-openbsd*) machine=pmax ;; - ns32k-*-openbsd*) machine=ns32000 ;; - sparc-*-openbsd*) machine=sparc ;; - vax-*-openbsd*) machine=vax ;; esac ;; @@ -1489,9 +1475,6 @@ dnl Linux/68k m68k-*-linux* ) machine=m68k opsys=linux ;; - dnl Linux/arm - arm-*-linux* ) machine=arm opsys=linux ;; - esac if test -z "$machine" -o -z "$opsys"; then @@ -1728,7 +1711,7 @@ dnl The value of CPP is a quoted variable reference, so we need to do this dnl to get its actual value... -CPP=`eval "echo $CPP"` +CPP=`eval "echo $CPP $CPPFLAGS"` define(TAB, [ ])dnl changequote(, )dnl eval `$CPP -Isrc $tempcname \ @@ -1787,8 +1770,8 @@ set x $[$1]; shift; [$1]="" while test -n "[$]1"; do case [$]1 in - -L | -l | -u ) [$1]="$[$1] [$]1 [$]2"; shift ;; - -L* | -l* | -u* | -Wl* ) [$1]="$[$1] [$]1" ;; + -L | -l | -u ) [$1]="$[$1] [$]1 [$]2"; shift ;; + -L* | -l* | -u* | -Wl* | -pg ) [$1]="$[$1] [$]1" ;; -Xlinker* ) ;; * ) [$1]="$[$1] -Xlinker [$]1" ;; esac @@ -1860,39 +1843,61 @@ dnl Add site and system specific flags to compile and link commands dnl --------------------------------------------------------------- -dnl All dirs present in site-prefixes will be searched for include/ and lib/ -dnl subdirs. This can avoid specifying both site-includes and site-libraries. -dnl Those dirs will take precedence over the standard places, but not over -dnl site-includes and site-libraries. - -dnl --site-prefixes (multiple dirs) -if test -n "$site_prefixes"; then - for arg in $site_prefixes; do - case "$arg" in - -* ) ;; - * ) argi="-I${arg}/include" ; argl="-L${arg}/lib" ;; - esac - XE_APPEND($argi, c_switch_site) - XE_APPEND($argl, ld_switch_site) - done -fi +dnl Allow use of either ":" or spaces for lists of directories +define(COLON_TO_SPACE, + [case "$[$1]" in *:* [)] [$1]="`echo '' $[$1] | sed -e 's/^ //' -e 's/:/ /g'`";; esac])dnl dnl --site-libraries (multiple dirs) +COLON_TO_SPACE(site_libraries) if test -n "$site_libraries"; then for arg in $site_libraries; do - case "$arg" in -* ) ;; * ) arg="-L${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + XE_DIE("Invalid site library \`$arg': no such directory") + arg="-L${arg}" ;; + esac XE_APPEND($arg, ld_switch_site) done fi dnl --site-includes (multiple dirs) +COLON_TO_SPACE(site_includes) if test -n "$site_includes"; then for arg in $site_includes; do - case "$arg" in -* ) ;; * ) arg="-I${arg}" ;; esac + case "$arg" in + -* ) ;; + * ) test -d "$arg" || \ + XE_DIE("Invalid site include \`$arg': no such directory") + arg="-I${arg}" ;; + esac XE_APPEND($arg, c_switch_site) done fi +dnl --site-prefixes (multiple dirs) +dnl --site-prefixes=dir1:dir2 is a convenient shorthand for +dnl --site-libraries=dir1/lib:dir2/lib --site-includes=dir1/include:dir2/include +dnl Site prefixes take precedence over the standard places, but not over +dnl site-includes and site-libraries. +COLON_TO_SPACE(site_prefixes) +if test -n "$site_prefixes"; then + for dir in $site_prefixes; do + inc_dir="${dir}/include" + lib_dir="${dir}/lib" + if test ! -d "$dir"; then + XE_DIE("Invalid site prefix \`$dir': no such directory") + elif test ! -d "$inc_dir"; then + XE_DIE("Invalid site prefix \`$dir': no such directory \`$inc_dir'") + elif test ! -d "$lib_dir"; then + XE_DIE("Invalid site prefix \`$dir': no such directory \`$lib_dir'") + else + XE_APPEND("-I$inc_dir", c_switch_site) + XE_APPEND("-L$lib_dir", ld_switch_site) + fi + done +fi + dnl GNU software installs by default into /usr/local/{include,lib} dnl if test -d "/usr/local/include" -a -d "/usr/local/lib"; then dnl XE_APPEND("-L/usr/local/lib", ld_switch_site) @@ -1905,6 +1910,7 @@ done dnl --site-runtime-libraries (multiple dirs) +COLON_TO_SPACE(site_runtime_libraries) if test -n "$site_runtime_libraries"; then LD_RUN_PATH="`echo $site_runtime_libraries | sed -e 's/ */:/g'`" export LD_RUN_PATH @@ -2092,7 +2098,7 @@ dnl checks for header files AC_CHECK_HEADERS(mach/mach.h sys/stropts.h sys/timeb.h sys/time.h unistd.h) AC_CHECK_HEADERS(utime.h locale.h libgen.h fcntl.h ulimit.h cygwin/version.h) -AC_CHECK_HEADERS(linux/version.h kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h) +AC_CHECK_HEADERS(kstat.h sys/pstat.h inttypes.h sys/un.h a.out.h) AC_HEADER_SYS_WAIT AC_HEADER_STDC AC_HEADER_TIME @@ -2464,12 +2470,12 @@ test "$with_dialogs" != "no" && with_dialogs=msw \ && XE_ADD_OBJS(dialog-msw.o) else - test "$with_scrollbars" != "no" && XE_ADD_OBJS(scrollbar-msw.o) + test "$with_scrollbars" != "no" && XE_ADD_OBJS(scrollbar-msw.o) test "$with_menubars" != "no" && XE_ADD_OBJS(menubar-msw.o) test "$with_toolbars" != "no" && XE_ADD_OBJS(toolbar-msw.o) - test "$with_dialogs" != "no" && XE_ADD_OBJS(dialog-msw.o) + test "$with_dialogs" != "no" && XE_ADD_OBJS(dialog-msw.o) fi - dnl check for our special version of select + dnl check for our special version of select AC_TRY_RUN([#include int main() { return (open("/dev/windows", O_RDONLY, 0) > 0)? 0 : 1; }], [AC_DEFINE(HAVE_MSG_SELECT)]) @@ -2617,7 +2623,7 @@ fi dnl Always compile OffiX unless --without-offix is given, no -dnl X11 support is compiled in, no standard Xmu is avaiable, +dnl X11 support is compiled in, no standard Xmu is available, dnl or dragndrop support is disabled dnl Because OffiX support currently loses when more than one display dnl is in use, we now disable it by default -slb 07/10/1998. @@ -3390,7 +3396,7 @@ XE_ADD_OBJS(nas.o) XE_PREPEND(-laudio, libs_x) dnl If the nas library does not contain the error jump point, - dnl then we force safer behaviour. + dnl then we force safer behavior. AC_EGREP_HEADER(AuXtErrorJump,audio/Xtutil.h,,[AC_DEFINE(NAS_NO_ERROR_JUMP)]) esac @@ -3652,7 +3658,7 @@ dnl Compute lists of Makefiles and subdirs AC_SUBST(SRC_SUBDIR_DEPS) XE_APPEND(src, MAKE_SUBDIR) -internal_makefile_list="Makefile" +internal_makefile_list="Makefile.in" SUBDIR_MAKEFILES='' test -d lock || mkdir lock for dir in $MAKE_SUBDIR; do @@ -3864,7 +3870,13 @@ AC_SUBST(RANLIB) AC_SUBST(dynodump_arch) -# The default is yes +dnl Preliminary support for using a different compiler for xemacs itself. +dnl Useful for building XEmacs with a C++ or 64-bit compiler. +: ${XEMACS_CC:=$CC} +AC_SUBST(XEMACS_CC) + + +dnl The default is yes if test "$with_site_lisp" = "no"; then AC_DEFINE(INHIBIT_SITE_LISP) fi @@ -3900,9 +3912,9 @@ test "$with_i18n3" = "yes" && AC_DEFINE(I18N3) test "$GCC" = "yes" && AC_DEFINE(USE_GCC) test "$external_widget" = "yes" && AC_DEFINE(EXTERNAL_WIDGET) -test "$with_gnu_make" = "yes" && AC_DEFINE(USE_GNU_MAKE) test "$no_doc_file" = "yes" && AC_DEFINE(NO_DOC_FILE) dnl test "$const_is_losing" = "yes" && AC_DEFINE(CONST_IS_LOSING) +test "$with_purify" = "yes" && AC_DEFINE(PURIFY) test "$with_quantify" = "yes" && AC_DEFINE(QUANTIFY) test "$with_pop" = "yes" && AC_DEFINE(MAIL_USE_POP) test "$with_kerberos" = "yes" && AC_DEFINE(KERBEROS) @@ -3999,7 +4011,7 @@ native ) echo " Compiling in native sound support." ;; both ) echo " Compiling in both network and native sound support." ;; esac -test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously" +test "$old_nas" = yes && echo " nas library lacks error trapping, will play synchronously." test "$with_database_berkdb" = yes && echo " Compiling in support for Berkeley DB." test "$with_database_dbm" = yes && echo " Compiling in support for DBM." @@ -4053,9 +4065,9 @@ test "$with_clash_detection" = yes && \ echo " Clash detection will use \"$lockdir\" for locking files." echo " movemail will use \"$mail_locking\" for locking mail spool files." -test "$with_pop" = yes && echo " Using POP for mail access" -test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication" -test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host" +test "$with_pop" = yes && echo " Using POP for mail access." +test "$with_kerberos" = yes && echo " Using Kerberos for POP authentication." +test "$with_hesiod" = yes && echo " Using Hesiod to get POP server host." test "$use_union_type" = yes && echo " Using the union type for Lisp_Objects." test "$use_minimal_tagbits" = yes && echo " Using Lisp_Objects with minimal tagbits." test "$use_indexed_lrecord_implementation" = yes && echo " Using indexed lrecord implementation." @@ -4083,7 +4095,6 @@ dnl ----------------------------------- dnl Now generate config.h and Makefiles dnl ----------------------------------- - dnl This has to be called in order for this variable to get into config.status AC_SUBST(internal_makefile_list) # Remove any trailing slashes in these variables. @@ -4103,41 +4114,57 @@ ac_output_files="$ac_output_files src/paths.h lib-src/config.values" AC_OUTPUT($ac_output_files, -[for dir in $MAKE_SUBDIR; do - echo creating $dir/Makefile +[for dir in . $MAKE_SUBDIR; do ( -changequote(<<, >>)dnl cd $dir rm -f junk.c < Makefile.in \ sed -e '/^# Generated/d' \ -e 's%/\*\*/#.*%%' \ -e 's/^ *# */#/' \ +dnl Delete Makefile.in.in comment lines -e '/^##/d' \ +dnl Pass through CPP directives unchanged -e '/^#/ { p d -}' -e '/./ { -s/\([\"]\)/\\\1/g +}' \ +dnl Quote other lines to protect from CPP substitution + -e '/./ { +s/\([[\"]]\)/\\\1/g s/^/"/ s/$/"/ }' > junk.c; - $CPP -I. -I${top_srcdir}/src $CPPFLAGS junk.c > junk.cpp; - < junk.cpp \ - sed -e 's/^#.*//' \ - -e 's/^[ TAB][ TAB]*$//' \ - -e 's/^ /TAB/' \ - | sed -n -e '/^..*$/p' \ - | sed '/^"/ { -s/\\\([\"]\)/\1/g -s/^[ TAB]*"// -s/"[ TAB]*$// -}' > Makefile.new + +dnl Create a GNUmakefile and Makefile from Makefile.in. + +changequote(<<,>>)dnl +dnl CPP_MAKEFILE(CPPFLAGS,filename) +define(<>, +echo creating $dir/<<$2>> +$CPP -I. -I${top_srcdir}/src <<$1>> junk.c \ +dnl Delete line directives inserted by $CPP + | sed -e 's/^\#.*//' \ +dnl Delete spurious blanks inserted by $CPP + -e 's/^[ TAB][ TAB]*$//'\ + -e 's/^ /TAB/' \ +dnl Delete blank lines + | sed -n -e '/^..*$/p' \ +dnl Restore lines quoted above to original contents. + | sed '/^\"/ { + s/\\\([\"]\)/\1/g + s/^[ TAB]*\"// + s/\"[ TAB]*$// +}' > Makefile.new chmod 444 Makefile.new - mv -f Makefile.new Makefile - rm -f junk.c junk.cpp -changequote([, ])dnl -) + mv -f Makefile.new <<$2>> +)dnl CPP_MAKEFILE + + CPP_MAKEFILE(,Makefile) + CPP_MAKEFILE(-DUSE_GNU_MAKE,GNUmakefile) +changequote([,])dnl + rm -f junk.c + ) done dnl Append AC_DEFINE information to lib-src/config.values @@ -4150,7 +4177,6 @@ ], [CPP="$CPP" - CPPFLAGS="$CPPFLAGS" top_srcdir="$srcdir" MAKE_SUBDIR="$MAKE_SUBDIR" -]) +])dnl diff -r 76b7d63099ad -r 8626e4521993 configure.usage --- a/configure.usage Mon Aug 13 11:06:08 2007 +0200 +++ b/configure.usage Mon Aug 13 11:07:10 2007 +0200 @@ -3,7 +3,7 @@ Set compilation and installation parameters for XEmacs, and report. Note that for most of the following options, you can explicitly enable -them using `--OPTION=yes' and explicitly disable them using `--OPTION=no'. +them using `--OPTION=yes' and explicitly disable them using `--OPTION=no'. This is especially useful for auto-detected options. The option `--without-FEATURE' is a synonym for `--with-FEATURE=no'. @@ -24,11 +24,6 @@ --compiler=prog C compiler to use. --with-gcc (*) Use GCC to compile XEmacs. --without-gcc Don't use GCC to compile XEmacs. ---with-gnu-make Write the Makefiles to take advantage of - special features of GNU Make. (GNU Make - works fine on the Makefiles even without this - option. This just allows for simultaneous - in-place and --srcdir building.) --cflags=FLAGS Compiler flags (such as -O) --cpp=prog C preprocessor to use (e.g. /usr/ccs/lib/cpp or cc -E) --cppflags=FLAGS C preprocessor flags (e.g. -I/foo or -Dfoo=bar) @@ -46,7 +41,7 @@ --dynamic=no Force static linking on systems where dynamic linking is the default. --srcdir=DIR Look for the XEmacs source files in DIR. - See also --with-gnu-make. + Works best when using GNU Make. --use-indexed-lrecord-implementation --use-minimal-tagbits --gung-ho Build with new-style Lisp_Objects. @@ -124,7 +119,7 @@ --with-socks Compile with support for SOCKS (an Internet proxy). --with-database=TYPE (*) Compile with database support. Valid types are `no' or a comma-separated list of one or more - of `dbm', `gnudbm', or `berkdb'. + of `berkdb' and either `dbm' or `gnudbm'. --with-sound=native (*) Compile with native sound support. --with-sound=nas Compile with network sound support. --with-sound=both Compile with native and network sound support. @@ -140,17 +135,17 @@ --mail-locking=TYPE (*) Specify the locking to be used by movemail to prevent concurrent updates of mail spool files. Valid types are `lockf', `flock', and `file'. ---with-site-lisp Allow for a site-lisp directory in the XEmacs hierarchy +--with-site-lisp Allow for a site-lisp directory in the XEmacs hierarchy searched before the installation packages. --package-path=PATH Directories to search for packages to dump with xemacs. PATH splits into three parts separated by double colons (::), an early, a late, and a last part, corresponding to their position in the various - system paths: The early part is always first, - the late part somewhere in the middle, and the + system paths: The early part is always first, + the late part somewhere in the middle, and the last part at the very back. Only the late part gets seen at dump time. - If PATH has only one component, that component + If PATH has only one component, that component is late. If PATH has two components, the first is early, the second is late. @@ -221,6 +216,8 @@ Defaults to `${statedir}/xemacs/lock'. --with-system-malloc Force use of the system malloc, rather than GNU malloc. --with-debug-malloc Use the debugging malloc package. +--with-quantify Add support for performance debugging using Quantify. +--with-purify Add support for memory debugging using Purify. You may also specify any of the `path' variables found in Makefile.in, including --bindir, --libdir, --lispdir, --sitelispdir, --datadir, diff -r 76b7d63099ad -r 8626e4521993 etc/MOTIVATION --- a/etc/MOTIVATION Mon Aug 13 11:06:08 2007 +0200 +++ b/etc/MOTIVATION Mon Aug 13 11:07:10 2007 +0200 @@ -96,7 +96,7 @@ First, rewards encourage people to focus narrowly on a task, to do it as quickly as possible and to take few risks. "If they feel that -'this is something I hve to get through to get the prize,' the're +'this is something I have to get through to get the prize,' they're going to be less creative," Amabile said. Second, people come to see themselves as being controlled by the diff -r 76b7d63099ad -r 8626e4521993 etc/NEWS --- a/etc/NEWS Mon Aug 13 11:06:08 2007 +0200 +++ b/etc/NEWS Mon Aug 13 11:07:10 2007 +0200 @@ -9,7 +9,7 @@ Use `C-c C-f' to move to the next equal level of outline, and `C-c C-b' to move to previous equal level. `C-h m' will give more -info about the Outline mode. Many commands are also available through +info about the Outline mode. Many commands are also available through the menubar. Users who would like to know which capabilities have been introduced @@ -54,13 +54,73 @@ children of a base buffer. -* Lisp and internal changes in XEmacs 21.0 +* Lisp and internal changes in XEmacs 21.2 ========================================== ** Functions for decoding base64 encoding are now available; see `base64-encode-region', `base64-encode-string', `base64-decode-region' and `base64-decode-string'. +** Many basic lisp operations are now faster. +This is especially the case when running a Mule-enabled XEmacs. + +A general overhaul of the lisp engine should produce a speedup of 1.4 +in a Latin-1 XEmacs, and 2.1 in a Mule XEmacs. These numbers were +obtained running (byte-compile "simple.el"), which should be a pretty +typical test of `pure' lisp. + +Lisp hash tables have been re-implemented. The Common Lisp style hash +table interface has been made standard, and moved from cl.el into fast +C code (See the section on hash tables in the XEmacs Lisp Reference). +A speedup factor of 3 can be expected with code that makes intensive +use of hash tables. + +The garbage collector has been tuned, leading to a speedup of 1.16. + +The family of functions that iterate over lists, like `memq', and +`rassq', have been made a little faster (typically 1.3). + +Lisp function calls are faster, by approximately a factor of two. +However, defining inline functions (via defsubst) still make sense. + +And finally, a few functions have had dramatic performance +improvements. For example, (last long-list) is now 30 times faster. + +Of course, your mileage will vary. + +Many operations do not see any improvement. Surprisingly, running +(font-lock-refontify-buffer) does not use the Lisp engine much at all. +Speeding up your favorite slow operation is an excellent project to +improve XEmacs. Don't forget to profile! + +** XEmacs finally has an automated test suite! +Although this is not yet very sophisticated, it is already responsible +for several important bug fixes in XEmacs. To try it out, simply use +the makefile target `make check' after building XEmacs. + +** New hash table implementation +As was pointed out above, the standard interface to hash tables is now +the Common Lisp interface, as described in Common Lisp, the Language +(CLtL2, by Steele). The older interface (functions with names +containing the phrase `hashtable') will continue to work, but the +preferred interface now has names containing the phrase `hash-table'. + +Here's the executive overview: create hash tables using +make-hash-table, and use gethash, puthash, remhash, maphash and +clrhash to manipulate entries in the hash table. See the (updated) +Lisp Reference Manual for details. + +** Lisp code handles circular lists much more robustly. +Many basic lisp functions used to loop forever when given a circular +list. Now this is more likely to trigger a `circular-list' error. +Printing a circular list now results in something like this: + + (progn (setq x (cons 'foo 'foo)) (setcdr x x) x) +==> (foo ... ) + +An extra bonus is that checking for circularities is not just +friendlier, but actually faster than checking for quit. + * Changes in XEmacs 21.0 ======================== @@ -111,15 +171,15 @@ ** The new variable `user-full-name' can be used to customize one's name when using the Emacs mail and news reading facilities. -Normally, `user-full-name' is a function that returns the full name of +Normally, `user-full-name' is a function that returns the full name of a user or UID, as specified by the system -- for instance, -(user-full-name "root") returns something like "Super-User". However, +(user-full-name "root") returns something like "Super-User". However, when the function is called without arguments, it will return the -value of the `user-full-name' variable. The `user-full-name' variable +value of the `user-full-name' variable. The `user-full-name' variable is initialized using the environment variable NAME and (failing that) the user's system name. -The behaviour of the `user-full-name' function with an argument +The behavior of the `user-full-name' function with an argument specified is unchanged. ** The new command `M-x customize-changed-options' lets you customize @@ -278,7 +338,7 @@ *** \\1-expressions are now valid in `nnmail-split-methods'. -*** The `custom-face-lookup' function has been removed. +*** The `custom-face-lookup' function has been removed. If you used this function in your initialization files, you must rewrite them to use `face-spec-set' instead. @@ -328,7 +388,7 @@ subsystem. If the `dir' file does not exist in an Info directory, the relevant information will be generated on-the-fly. -This behaviour can be customized, look for `Info-auto-generate-directory' +This behavior can be customized, look for `Info-auto-generate-directory' and `Info-save-auto-generated-dir' in the `info' customization group. @@ -368,7 +428,7 @@ only when needed, and they are not draggable. Other properties of the vertical dividers may be controlled using -`vertical-divider-shadow-thickness', `vertical-divider-line-width' and +`vertical-divider-shadow-thickness', `vertical-divider-line-width' and `vertical-divider-spacing' specifiers, which see. ** Frame focus management changes. @@ -440,7 +500,7 @@ ** It is now possible to build XEmacs with LDAP support. You will need to install a LDAP library first. The following have been tested: - - LDAP 3.3 from the University of Michigan + - LDAP 3.3 from the University of Michigan (get it from ) - LDAP SDK 1.0 from Netscape Corp. (get it from ) diff -r 76b7d63099ad -r 8626e4521993 lib-src/ChangeLog --- a/lib-src/ChangeLog Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/ChangeLog Mon Aug 13 11:07:10 2007 +0200 @@ -1,3 +1,7 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff -r 76b7d63099ad -r 8626e4521993 lib-src/gnuclient.c --- a/lib-src/gnuclient.c Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/gnuclient.c Mon Aug 13 11:07:10 2007 +0200 @@ -553,7 +553,7 @@ if (read_line (s, buffer) == 0) { - fprintf (stderr, "%s: Could not establish Emacs procces id\n", + fprintf (stderr, "%s: Could not establish Emacs process id\n", progname); exit (1); } diff -r 76b7d63099ad -r 8626e4521993 lib-src/gnuserv.c --- a/lib-src/gnuserv.c Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/gnuserv.c Mon Aug 13 11:07:10 2007 +0200 @@ -563,7 +563,7 @@ /* - setup_table -- initialise the table of hosts allowed to contact the server, + setup_table -- initialize the table of hosts allowed to contact the server, by reading from the file specified by the GNU_SECURE environment variable Put in the local machine, and, if a security file is specifed, @@ -832,9 +832,7 @@ int -main(argc,argv) - int argc; - char *argv[]; +main (int argc, char *argv[]) { int chan; /* temporary channel number */ #ifdef SYSV_IPC @@ -867,7 +865,7 @@ #endif /* SYSV_IPC */ #ifdef INTERNET_DOMAIN_SOCKETS - ils = internet_init(); /* get a internet domain socket to listen on */ + ils = internet_init(); /* get an internet domain socket to listen on */ #endif /* INTERNET_DOMAIN_SOCKETS */ #ifdef UNIX_DOMAIN_SOCKETS diff -r 76b7d63099ad -r 8626e4521993 lib-src/make-docfile.c --- a/lib-src/make-docfile.c Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/make-docfile.c Mon Aug 13 11:07:10 2007 +0200 @@ -1032,7 +1032,7 @@ else { #ifdef DEBUG - fprintf (stderr, "## unrecognised top-level form, %s (%s)\n", + fprintf (stderr, "## unrecognized top-level form, %s (%s)\n", buffer, filename); #endif continue; diff -r 76b7d63099ad -r 8626e4521993 lib-src/make-msgfile.c --- a/lib-src/make-msgfile.c Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/make-msgfile.c Mon Aug 13 11:07:10 2007 +0200 @@ -69,7 +69,7 @@ This program (make-msgfile.c) addresses the first part, extracting the strings. - For the emacs C code, we need to recognise the following patterns: + For the emacs C code, we need to recognize the following patterns: message ("string" ... ) error ("string") @@ -94,7 +94,7 @@ there are no alphabetic characters in it that are not a part of a `%' directive. (Careful not to translate either "%s%s" or "%s: ".) - For the emacs Lisp code, we need to recognise the following patterns: + For the emacs Lisp code, we need to recognize the following patterns: (message "string" ... ) (error "string" ... ) @@ -109,7 +109,7 @@ I expect there will be a lot like the above; basically, any function which is a commonly used wrapper around an eventual call to `message' or - `read-from-minibuffer' needs to be recognised by this program. + `read-from-minibuffer' needs to be recognized by this program. (dgettext "domain-name" "string") #### do we still need this? @@ -124,7 +124,7 @@ Menu descriptors: one way to extract the strings in menu labels would be to teach this program about "^(defvar .*menu\n" forms; that's probably kind of hard, though, so perhaps a better approach would be to make this - program recognise lines of the form + program recognize lines of the form "string" ... ;###translate diff -r 76b7d63099ad -r 8626e4521993 lib-src/make-msgfile.lex --- a/lib-src/make-msgfile.lex Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/make-msgfile.lex Mon Aug 13 11:07:10 2007 +0200 @@ -134,7 +134,7 @@ This program (make-msgfile.c) addresses the first part, extracting the strings. - For the emacs C code, we need to recognise the following patterns: + For the emacs C code, we need to recognize the following patterns: message ("string" ... ) error ("string") @@ -159,7 +159,7 @@ there are no alphabetic characters in it that are not a part of a `%' directive. (Careful not to translate either "%s%s" or "%s: ".) - For the emacs Lisp code, we need to recognise the following patterns: + For the emacs Lisp code, we need to recognize the following patterns: (message "string" ... ) (error "string" ... ) @@ -174,7 +174,7 @@ I expect there will be a lot like the above; basically, any function which is a commonly used wrapper around an eventual call to `message' or - `read-from-minibuffer' needs to be recognised by this program. + `read-from-minibuffer' needs to be recognized by this program. (dgettext "domain-name" "string") #### do we still need this? @@ -218,7 +218,7 @@ Menu descriptors: one way to extract the strings in menu labels would be to teach this program about "^(defvar .*menu\n" forms; that's probably kind of hard, though, so perhaps a better approach would be to make this - program recognise lines of the form + program recognize lines of the form "string" ... ;###translate diff -r 76b7d63099ad -r 8626e4521993 lib-src/movemail.c --- a/lib-src/movemail.c Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/movemail.c Mon Aug 13 11:07:10 2007 +0200 @@ -68,7 +68,7 @@ #include "getopt.h" #ifdef MAIL_USE_POP #include "pop.h" -#include +#include "../src/regex.h" #endif extern char *optarg; @@ -847,7 +847,7 @@ /* Turn a name, which is an ed-style (but Emacs syntax) regular expression, into a real regular expression by compiling it. */ static struct re_pattern_buffer* -compile_regex (char* regexp_pattern) +compile_regex (char* pattern) { char *err; struct re_pattern_buffer *patbuf=0; @@ -858,7 +858,7 @@ patbuf->buffer = NULL; patbuf->allocated = 0; - err = (char*) re_compile_pattern (regexp_pattern, strlen (regexp_pattern), patbuf); + err = (char*) re_compile_pattern (pattern, strlen (pattern), patbuf); if (err != NULL) { error ("%s while compiling pattern", err, NULL); diff -r 76b7d63099ad -r 8626e4521993 lib-src/pstogif --- a/lib-src/pstogif Mon Aug 13 11:06:08 2007 +0200 +++ b/lib-src/pstogif Mon Aug 13 11:07:10 2007 +0200 @@ -59,7 +59,7 @@ #$PSTOPPM= $ENV{'PSTOPPM'} || # 'pstoppm.ps'; -# Available in the PBMPLUS libary +# Available in the PBMPLUS library $PNMCROP=$ENV{'PNMCROP'} || 'pnmcrop' ; # Also in PBMPLUS diff -r 76b7d63099ad -r 8626e4521993 lisp/ChangeLog --- a/lisp/ChangeLog Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 11:07:10 2007 +0200 @@ -1,3 +1,204 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + +1998-12-05 SL Baur + + * files.el (binary-file-regexps): regexp-opt is not available at + bytecompile time. + +1998-11-30 Martin Buchholz + + * x-win-xfree86.el: + * x-win-sun.el (x-win-init-sun): + * x-win-sun.el: + * x-mouse.el (mouse-track-and-copy-to-cutbuffer): + * x-iso8859-1.el: + * x-init.el (init-post-x-win): + * x-init.el (init-pre-x-win): + * x-init.el (x-initialize-compose): + * x-init.el: + * x-compose.el: + * winnt.el: + * widget.el: + * wid-edit.el (widget-glyph-click): + * wid-edit.el (widget-glyph-find): + * wid-edit.el (widget-type): + * view-less.el (view-buffer-other-window): + * very-early-lisp.el: + * version.el: + * toolbar.el: + * toolbar-items.el: + * term/sun.el (suntool-map): + * term/sun-mouse.el: + * term/internal.el: + * syntax.el (modify-syntax-entry): + * symbol-syntax.el: + * subr.el: + * startup.el (lock-directory): + * simple.el (set-comment-column): + * simple.el (backward-delete-char-untabify): + * shadow.el (find-emacs-lisp-shadows): + * shadow.el: + * setup-paths.el (paths-construct-info-path): + * select.el (cut-copy-clear-internal): + * process.el (call-process-region): + * process.el (start-process-shell-command): + * process.el: + * paths.el (rmail-spool-directory): + * paragraphs.el (use-hard-newlines): + * package-get.el (package-get-dependencies): + * package-admin.el (package-admin-delete-binary-package): + * obsolete.el (truncate-string): + * obsolete.el (store-substring): + * mouse.el (default-mouse-track-maybe-own-selection): + * mouse.el (mouse-yank-at-point): + * modeline.el: + * modeline.el (mouse-drag-modeline): + * minibuf.el (read-directory-name-internal): + * minibuf.el (read-file-name-internal): + * minibuf.el (read-file-name-internal-1): + * minibuf.el (read-file-name-2): + * minibuf.el (exact-minibuffer-completion-p): + * minibuf.el (read-from-minibuffer): + * minibuf.el: + * menubar.el (check-menu-syntax): + * map-ynp.el (map-y-or-n-p): + * make-docfile.el (docfile-out-of-date): + * loadup.el ((member "run-temacs" command-line-args)): + * loadup.el ((member "no-site-file" command-line-args)): + * loadup.el (really-early-error-handler): + * loadup.el: + * loadhist.el: + * loaddefs.el: + * lisp-mnt.el (lm-verify): + * lib-complete.el (lib-complete:cache-completions): + * lib-complete.el (library-all-completions): + * itimer.el (itimer-run-expired-timers): + * info.el (Info-mode): + * info.el (Info-insert-file-contents): + * info.el (Info-rebuild-dir): + * info.el (Info-build-dir-anew): + * info.el (Info-parse-dir-entries): + * info.el (Info-dir-outdated-p): + * info.el (Info-insert-dir): + * info.el (info-xref): + * info.el: + * hyper-apropos.el (hyper-apropos-get-doc): + * hyper-apropos.el (hyper-describe-face): + * hyper-apropos.el (hyper-apropos-mode): + * hyper-apropos.el: + * help.el (list-processes): + * help.el: + * gnuserv.el: + * font.el (mswindows-font-create-name): + * font.el (font-default-font-for-device): + * font.el (x-font-create-object): + * font.el (font-registry): + * font.el: + * font-lock.el (font-lock-keywords): + * font-lock.el: + * finder.el (finder-compile-keywords): + * find-paths.el (paths-find-recursive-path): + * fill.el (set-justification-center): + * fill.el (fill-region-as-paragraph): + * files.el (insert-directory): + * files.el (wildcard-to-regexp): + * files.el (recover-file): + * files.el (basic-save-buffer): + * files.el (delete-auto-save-file-if-necessary): + * files.el (file-relative-name): + * files.el (backup-extract-version): + * files.el (backup-buffer): + * files.el (set-visited-file-name): + * files.el (set-auto-mode): + * files.el (interpreter-mode-alist): + * files.el: + * files.el (find-file-noselect): + * files.el (abbreviate-file-name): + * files.el (parse-colon-path): + * files.el (directory-abbrev-alist): + * etags.el (visit-tags-table-buffer): + * easymenu.el (easy-menu-define): + * dragdrop.el (experimental-dragdrop-drag): + * dragdrop.el (dragdrop-drop-do-functions): + * dragdrop.el (dragdrop-drop-at-point): + * disass.el (disassemble-1): + * disass.el (disassemble-internal): + * disass.el (disassemble): + * disass.el: + * derived.el (derived-mode-init-mode-variables): + * derived.el (define-derived-mode): + * custom.el (defgroup): + * cus-edit.el (custom-quote): + * config.el: + * code-process.el (open-network-stream): + * code-process.el (start-process): + * code-process.el (call-process-region): + * code-process.el (call-process): + * code-process.el: + * code-files.el (insert-file-contents): + * code-files.el: + * code-files.el (buffer-file-coding-system-for-read): + * cmdloop.el (yes-or-no-p-minibuf): + * cl.el: + * cl-macs.el: + * cl-extra.el: + * callers-of-rpt.el (make-caller-report): + * callers-of-rpt.el: + * bytecomp.el (batch-byte-recompile-directory): + * bytecomp.el (batch-byte-compile-1): + * bytecomp.el (batch-byte-compile): + * bytecomp.el (display-call-tree): + * bytecomp.el (byte-compile-insert): + * bytecomp.el (byte-compile-two-args-19->20): + * bytecomp.el (byte-compile-variable-ref): + * bytecomp.el (byte-compile-form): + * bytecomp.el (byte-compile-top-level-body): + * bytecomp.el (byte-compile-out-toplevel): + * bytecomp.el (byte-compile-byte-code-maker): + * bytecomp.el (byte-compile-file-form-defmumble): + * bytecomp.el (byte-compile-file-form): + * bytecomp.el (byte-compile-keep-pending): + * bytecomp.el (byte-compile-insert-header): + * bytecomp.el (byte-compile-from-buffer): + * bytecomp.el (byte-compile-file): + * bytecomp.el (byte-recompile-file): + * bytecomp.el (byte-compile-close-variables): + * bytecomp.el (byte-compile-warn-about-unused-variables): + * bytecomp.el (byte-compile-warn-about-unresolved-functions): + * bytecomp.el (byte-compiler-legal-options): + * bytecomp.el (byte-compile-lapcode): + * bytecomp.el (byte-optimize-log): + * bytecomp.el ((fboundp 'defsubst)): + * bytecomp.el: + * bytecomp-runtime.el: + * byte-optimize.el (byte-optimize-apply): + * byte-optimize.el (car): + * byte-optimize.el (byte-optimize-form): + * byte-optimize.el (byte-optimize-form-code-walker): + * byte-optimize.el: + * build-report.el (build-report-insert-installation-file): + * build-report.el (build-report): + * auto-show.el: + * apropos.el (apropos-documentation): + - mega patch + - clean up byte-compile warnings + - remove unused variables + - Use common lisp style hashtable functions + - byte compiler cleanup + - use #'(lambda ...) instead of '(lambda ...) or (function (lambda ...)) + - remove old backquote syntax usage + - move some cl functionality into C for speed. + - remove last remaining VMS support + - spelling fixes + - implement last, butlast, nbutlast, copy-list in C. + - new macro ignore-file-errors, similar to ignore-errors + (ignore-file-errors (delete-file "foo")) + - get frequent garbage collection during loadup.el by tweaking + gc-cons-threshold, rather than explicitly calling garbage-collect + - default delete-key-deletes-forward to `t'. + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. @@ -362,7 +563,7 @@ mswindows-make-font-bold / -bold-italic: Supplied device was not being passed into call to mswindows-find-smaller-font. -1998-09-10 Björn Torkelsson +1998-09-10 Bjrn Torkelsson * package-get.el (package-get-remote): Fix the path where to find the packages on xemacs.org. diff -r 76b7d63099ad -r 8626e4521993 lisp/apropos.el --- a/lisp/apropos.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/apropos.el Mon Aug 13 11:07:10 2007 +0200 @@ -309,7 +309,7 @@ (lambda (symbol) (setq f (apropos-safe-documentation symbol) v (get symbol 'variable-documentation)) - (if (integerp v) (setq v)) + (when (integerp v) (setq v nil)) (setq f (apropos-documentation-internal f) v (apropos-documentation-internal v)) (if (or f v) diff -r 76b7d63099ad -r 8626e4521993 lisp/auto-show.el --- a/lisp/auto-show.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/auto-show.el Mon Aug 13 11:07:10 2007 +0200 @@ -140,8 +140,7 @@ that the region will be visible when `auto-show-make-point-visible' is next called (this happens after every command)." (if (auto-show-should-take-action-p) - (let* ((col (current-column)) ;column on line point is at - (scroll (window-hscroll));how far window is scrolled + (let* ((scroll (window-hscroll)) ;how far window is scrolled (w-width (- (window-width) (if (> scroll 0) 2 1))) ;how wide window is on the screen diff -r 76b7d63099ad -r 8626e4521993 lisp/build-report.el --- a/lisp/build-report.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/build-report.el Mon Aug 13 11:07:10 2007 +0200 @@ -169,6 +169,7 @@ (prompts build-report-prompts)) (progn (while prompts + (defvar hist) (setq prompt (caar prompts)) (setq hist (cdar prompts)) (setq prompts (cdr prompts)) @@ -283,12 +284,12 @@ (defun build-report-keep () "build-report-internal function of no general value." - (mapconcat '(lambda (item) item) + (mapconcat #'identity (cons "^--\\[\\[\\|\\]\\]$" build-report-keep-regexp) "\\|")) (defun build-report-delete () "build-report-internal function of no general value." - (mapconcat '(lambda (item) item) + (mapconcat #'identity build-report-delete-regexp "\\|")) ;;; build-report.el ends here diff -r 76b7d63099ad -r 8626e4521993 lisp/byte-optimize.el --- a/lisp/byte-optimize.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/byte-optimize.el Mon Aug 13 11:07:10 2007 +0200 @@ -1,4 +1,4 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler. +;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler. ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. @@ -39,7 +39,7 @@ ;; TO DO: ;; -;; (apply '(lambda (x &rest y) ...) 1 (foo)) +;; (apply #'(lambda (x &rest y) ...) 1 (foo)) ;; ;; maintain a list of functions known not to access any global variables ;; (actually, give them a 'dynamically-safe property) and then @@ -149,7 +149,7 @@ ;; in some grody way, but that's a really bad idea.) ;; ;; HA! RMS removed the following paragraph from his version of -;; byte-opt.el. +;; byte-optimize.el. ;; ;; Really the Right Thing is to make lexical scope the default across ;; the board, in the interpreter and compiler, and just FIX all of @@ -158,14 +158,14 @@ ;; Other things to consider: ;; Associative math should recognize subcalls to identical function: -;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) +;;(disassemble #'(lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) ;; This should generate the same as (1+ x) and (1- x) -;;(disassemble (lambda (x) (cons (+ x 1) (- x 1)))) +;;(disassemble #'(lambda (x) (cons (+ x 1) (- x 1)))) ;; An awful lot of functions always return a non-nil value. If they're ;; error free also they may act as true-constants. -;;(disassemble (lambda (x) (and (point) (foo)))) +;;(disassemble #'(lambda (x) (and (point) (foo)))) ;; When ;; - all but one arguments to a function are constant ;; - the non-constant argument is an if-expression (cond-expression?) @@ -174,20 +174,20 @@ ;; arguments may be any expressions. Since, however, the code size ;; can increase this way they should be "simple". Compare: -;;(disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) -;;(disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) +;;(disassemble #'(lambda (x) (eq (if (point) 'a 'b) 'c))) +;;(disassemble #'(lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) ;; (car (cons A B)) -> (progn B A) -;;(disassemble (lambda (x) (car (cons (foo) 42)))) +;;(disassemble #'(lambda (x) (car (cons (foo) 42)))) ;; (cdr (cons A B)) -> (progn A B) -;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) +;;(disassemble #'(lambda (x) (cdr (cons 42 (foo))))) ;; (car (list A B ...)) -> (progn B ... A) -;;(disassemble (lambda (x) (car (list (foo) 42 (bar))))) +;;(disassemble #'(lambda (x) (car (list (foo) 42 (bar))))) ;; (cdr (list A B ...)) -> (progn A (list B ...)) -;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) +;;(disassemble #'(lambda (x) (cdr (list 42 (foo) (bar))))) ;;; Code: @@ -199,31 +199,32 @@ (error "The old version of the disassembler is loaded. Reload new-bytecomp as well.")) (byte-compile-log-1 (apply 'format format - (let (c a) - (mapcar '(lambda (arg) - (if (not (consp arg)) - (if (and (symbolp arg) - (string-match "^byte-" (symbol-name arg))) - (intern (substring (symbol-name arg) 5)) - arg) - (if (integerp (setq c (car arg))) - (error "non-symbolic byte-op %s" c)) - (if (eq c 'TAG) - (setq c arg) - (setq a (cond ((memq c byte-goto-ops) - (car (cdr (cdr arg)))) - ((memq c byte-constref-ops) - (car (cdr arg))) - (t (cdr arg)))) - (setq c (symbol-name c)) - (if (string-match "^byte-." c) - (setq c (intern (substring c 5))))) - (if (eq c 'constant) (setq c 'const)) - (if (and (eq (cdr arg) 0) - (not (memq c '(unbind call const)))) - c - (format "(%s %s)" c a)))) - args))))) + (let (c a) + (mapcar + #'(lambda (arg) + (if (not (consp arg)) + (if (and (symbolp arg) + (string-match "^byte-" (symbol-name arg))) + (intern (substring (symbol-name arg) 5)) + arg) + (if (integerp (setq c (car arg))) + (error "non-symbolic byte-op %s" c)) + (if (eq c 'TAG) + (setq c arg) + (setq a (cond ((memq c byte-goto-ops) + (car (cdr (cdr arg)))) + ((memq c byte-constref-ops) + (car (cdr arg))) + (t (cdr arg)))) + (setq c (symbol-name c)) + (if (string-match "^byte-." c) + (setq c (intern (substring c 5))))) + (if (eq c 'constant) (setq c 'const)) + (if (and (eq (cdr arg) 0) + (not (memq c '(unbind call const)))) + c + (format "(%s %s)" c a)))) + args))))) (defmacro byte-compile-log-lap (format-string &rest args) (list 'and @@ -238,20 +239,21 @@ (defun byte-optimize-inline-handler (form) "byte-optimize-handler for the `inline' special-form." - (cons 'progn - (mapcar - '(lambda (sexp) - (let ((fn (car-safe sexp))) - (if (and (symbolp fn) - (or (cdr (assq fn byte-compile-function-environment)) - (and (fboundp fn) - (not (or (cdr (assq fn byte-compile-macro-environment)) - (and (consp (setq fn (symbol-function fn))) - (eq (car fn) 'macro)) - (subrp fn)))))) - (byte-compile-inline-expand sexp) - sexp))) - (cdr form)))) + (cons + 'progn + (mapcar + #'(lambda (sexp) + (let ((fn (car-safe sexp))) + (if (and (symbolp fn) + (or (cdr (assq fn byte-compile-function-environment)) + (and (fboundp fn) + (not (or (cdr (assq fn byte-compile-macro-environment)) + (and (consp (setq fn (symbol-function fn))) + (eq (car fn) 'macro)) + (subrp fn)))))) + (byte-compile-inline-expand sexp) + sexp))) + (cdr form)))) ;; Splice the given lap code into the current instruction stream. @@ -392,27 +394,29 @@ ;; are more deeply nested are optimized first. (cons fn (cons - (mapcar '(lambda (binding) - (if (symbolp binding) - binding - (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: %s" - (prin1-to-string binding))) - (list (car binding) - (byte-optimize-form (nth 1 binding) nil)))) - (nth 1 form)) + (mapcar + #'(lambda (binding) + (if (symbolp binding) + binding + (if (cdr (cdr binding)) + (byte-compile-warn "malformed let binding: %s" + (prin1-to-string binding))) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + (nth 1 form)) (byte-optimize-body (cdr (cdr form)) for-effect)))) ((eq fn 'cond) (cons fn - (mapcar '(lambda (clause) - (if (consp clause) - (cons - (byte-optimize-form (car clause) nil) - (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: %s" - (prin1-to-string clause)) - clause)) - (cdr form)))) + (mapcar + #'(lambda (clause) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: %s" + (prin1-to-string clause)) + clause)) + (cdr form)))) ((eq fn 'progn) ;; as an extra added bonus, this simplifies (progn ) --> (if (cdr (cdr form)) @@ -542,7 +546,7 @@ ;; First, optimize all sub-forms of this one. (setq form (byte-optimize-form-code-walker form for-effect)) ;; - ;; after optimizing all subforms, optimize this form until it doesn't + ;; After optimizing all subforms, optimize this form until it doesn't ;; optimize any further. This means that some forms will be passed through ;; the optimizer many times, but that's necessary to make the for-effect ;; processing do as much as possible. @@ -564,10 +568,10 @@ (defun byte-optimize-body (forms all-for-effect) - ;; optimize the cdr of a progn or implicit progn; all forms is a list of + ;; Optimize the cdr of a progn or implicit progn; `forms' is a list of ;; forms, all but the last of which are optimized with the assumption that - ;; they are being called for effect. the last is for-effect as well if - ;; all-for-effect is true. returns a new list of forms. + ;; they are being called for effect. The last is for-effect as well if + ;; all-for-effect is true. Returns a new list of forms. (let ((rest forms) (result nil) fe new) @@ -592,9 +596,10 @@ ;; I'd like this to be a defsubst, but let's not be self-referential... (defmacro byte-compile-trueconstp (form) ;; Returns non-nil if FORM is a non-nil constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((eq (, form) t))))) + `(cond ((consp ,form) (eq (car ,form) 'quote)) + ((not (symbolp ,form))) + ((eq ,form t)) + ((keywordp ,form)))) ;; If the function is being called with constant numeric args, ;; evaluate as much as possible at compile-time. This optimizer @@ -899,7 +904,7 @@ ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie -;; I think this may some times be necessary to reduce ie (quote 5) to 5, +;; I think this may some times be necessary to reduce eg. (quote 5) to 5, ;; so arithmetic optimizers recognize the numeric constant. - Hallvard (put 'quote 'byte-optimizer 'byte-optimize-quote) (defun byte-optimize-quote (form) @@ -1052,7 +1057,7 @@ (if (listp (nth 1 last)) (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast - (mapcar '(lambda (x) (list 'quote x)) (nth 1 last)))) + (mapcar #'(lambda (x) (list 'quote x)) (nth 1 last)))) (byte-compile-warn "last arg to apply can't be a literal atom: %s" (prin1-to-string last)) @@ -1122,6 +1127,16 @@ file-newer-than-file-p file-readable-p file-symlink-p file-writable-p float floor format get get-buffer get-buffer-window getenv get-file-buffer + ;; hash-table functions + make-hash-table copy-hash-table + gethash + hash-table-count + hash-table-rehash-size + hash-table-rehash-threshold + hash-table-size + hash-table-test + hash-table-type + ;; int-to-string length log log10 logand logb logior lognot logxor lsh marker-buffer max member memq min mod @@ -1134,7 +1149,14 @@ ;; XEmacs change: window-edges -> window-pixel-edges window-buffer window-dedicated-p window-pixel-edges window-height window-hscroll window-minibuffer-p window-width - zerop)) + zerop + ;; functions defined by cl + oddp evenp plusp minusp + abs expt signum last butlast ldiff + pairlis gcd lcm + isqrt floor* ceiling* truncate* round* mod* rem* subseq + list-length get* getf + )) (side-effect-and-error-free-fns '(arrayp atom bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp @@ -1147,6 +1169,7 @@ dot dot-marker eobp eolp eq eql equal eventp extentp extent-live-p floatp framep frame-live-p get-largest-window get-lru-window + hash-table-p identity ignore integerp integer-or-marker-p interactive-p invocation-directory invocation-name ;; keymapp may autoload in XEmacs, so not on this list! @@ -1161,14 +1184,15 @@ user-full-name user-login-name user-original-login-name user-real-login-name user-real-uid user-uid vector vectorp - window-configuration-p window-live-p windowp))) - (while side-effect-free-fns - (put (car side-effect-free-fns) 'side-effect-free t) - (setq side-effect-free-fns (cdr side-effect-free-fns))) - (while side-effect-and-error-free-fns - (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free) - (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns))) - nil) + window-configuration-p window-live-p windowp + ;; Functions defined by cl + eql floatp-safe list* subst acons equalp random-state-p + copy-tree sublis + ))) + (dolist (fn side-effect-free-fns) + (put fn 'side-effect-free t)) + (dolist (fn side-effect-and-error-free-fns) + (put fn 'side-effect-free 'error-free))) (defun byte-compile-splice-in-already-compiled-code (form) @@ -1326,10 +1350,7 @@ (if endtag (setq lap (cons (cons nil endtag) lap))) ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) - (mapcar (function (lambda (elt) - (if (numberp elt) - elt - (cdr elt)))) + (mapcar #'(lambda (elt) (if (numberp elt) elt (cdr elt))) (nreverse lap)))) @@ -1953,17 +1974,18 @@ (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) - '(byte-optimize-form - byte-optimize-body - byte-optimize-predicate - byte-optimize-binary-predicate - ;; Inserted some more than necessary, to speed it up. - byte-optimize-form-code-walker - byte-optimize-lapcode)))) + (mapcar + #'(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-optimize-form + byte-optimize-body + byte-optimize-predicate + byte-optimize-binary-predicate + ;; Inserted some more than necessary, to speed it up. + byte-optimize-form-code-walker + byte-optimize-lapcode)))) nil) ;;; byte-optimize.el ends here diff -r 76b7d63099ad -r 8626e4521993 lisp/bytecomp-runtime.el --- a/lisp/bytecomp-runtime.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/bytecomp-runtime.el Mon Aug 13 11:07:10 2007 +0200 @@ -55,13 +55,13 @@ (apply 'nconc (mapcar - '(lambda (x) - (` ((or (memq (get '(, x) 'byte-optimizer) - '(nil byte-compile-inline-expand)) - (error - "%s already has a byte-optimizer, can't make it inline" - '(, x))) - (put '(, x) 'byte-optimizer 'byte-compile-inline-expand)))) + #'(lambda (x) + `((or (memq (get ',x 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error + "%s already has a byte-optimizer, can't make it inline" + ',x)) + (put ',x 'byte-optimizer 'byte-compile-inline-expand))) fns)))) @@ -71,10 +71,10 @@ (apply 'nconc (mapcar - '(lambda (x) - (` ((if (eq (get '(, x) 'byte-optimizer) - 'byte-compile-inline-expand) - (put '(, x) 'byte-optimizer nil))))) + #'(lambda (x) + `((if (eq (get ',x 'byte-optimizer) + 'byte-compile-inline-expand) + (put ',x 'byte-optimizer nil)))) fns)))) ;; This has a special byte-hunk-handler in bytecomp.el. @@ -178,7 +178,7 @@ If (featurep 'FEATURE), evals now; otherwise adds an elt to `after-load-alist' (which see), using FEATURE as filename if FILENAME is nil." (let ((file (or (cdr feature) (symbol-name (car feature))))) - `(let ((bodythunk (function (lambda () ,@body)))) + `(let ((bodythunk #'(lambda () ,@body))) (if (featurep ',(car feature)) (funcall bodythunk) (setq after-load-alist (cons '(,file . (list 'lambda '() bodythunk)) diff -r 76b7d63099ad -r 8626e4521993 lisp/bytecomp.el --- a/lisp/bytecomp.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/bytecomp.el Mon Aug 13 11:07:10 2007 +0200 @@ -9,7 +9,7 @@ ;; Subsequently modified by RMS and others. -(defconst byte-compile-version (purecopy "2.25 XEmacs; 22-Mar-96.")) +(defconst byte-compile-version (purecopy "2.26 XEmacs; 1998-10-07.")) ;; This file is part of XEmacs. @@ -101,6 +101,8 @@ ;;; 'unresolved (calls to unknown functions) ;;; 'callargs (lambda calls with args that don't ;;; match the lambda's definition) +;;; 'subr-callargs (calls to subrs with args that +;;; don't match the subr's definition) ;;; 'redefine (function cell redefined from ;;; a macro to a lambda or vice versa, ;;; or redefined to take other args) @@ -171,7 +173,7 @@ ;;; buffer, and that buffer is modified, you are asked whether you want ;;; to save the buffer before compiling. ;;; -;;; o You can add this to /etc/magic to make file(1) recognise the files +;;; o You can add this to /etc/magic to make file(1) recognize the files ;;; generated by this compiler: ;;; ;;; 0 string ;ELC GNU Emacs Lisp compiled file, @@ -210,17 +212,16 @@ be hard-coded into bytecomp when it compiles itself. If the compiler itself is compiled with optimization, this causes a speedup.") - (cond (byte-compile-single-version - (defmacro byte-compile-single-version () t) - (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) - (t - (defmacro byte-compile-single-version () nil) - (defmacro byte-compile-version-cond (cond) cond))) + (cond + (byte-compile-single-version + (defmacro byte-compile-single-version () t) + (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) + (t + (defmacro byte-compile-single-version () nil) + (defmacro byte-compile-version-cond (cond) cond))) ) -(defvar emacs-lisp-file-regexp (if (eq system-type 'vax-vms) - (purecopy "\\.EL\\(;[0-9]+\\)?$") - (purecopy "\\.el$")) +(defvar emacs-lisp-file-regexp (purecopy "\\.el$") "*Regexp which matches Emacs Lisp source files. You may want to redefine `byte-compile-dest-file' if you change this.") @@ -234,18 +235,16 @@ (funcall handler 'byte-compiler-base-file-name filename) filename))) -(or (fboundp 'byte-compile-dest-file) - ;; The user may want to redefine this along with emacs-lisp-file-regexp, - ;; so only define it if it is undefined. - (defun byte-compile-dest-file (filename) - "Convert an Emacs Lisp source file name to a compiled file name." - (setq filename (byte-compiler-base-file-name filename)) - (setq filename (file-name-sans-versions filename)) - (cond ((eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c")) - ((string-match emacs-lisp-file-regexp filename) - (concat (substring filename 0 (match-beginning 0)) ".elc")) - (t (concat filename ".elc"))))) +(unless (fboundp 'byte-compile-dest-file) + ;; The user may want to redefine this along with emacs-lisp-file-regexp, + ;; so only define it if it is undefined. + (defun byte-compile-dest-file (filename) + "Convert an Emacs Lisp source file name to a compiled file name." + (setq filename (byte-compiler-base-file-name filename)) + (setq filename (file-name-sans-versions filename)) + (if (string-match emacs-lisp-file-regexp filename) + (concat (substring filename 0 (match-beginning 0)) ".elc") + (concat filename ".elc")))) ;; This can be the 'byte-compile property of any symbol. (autoload 'byte-compile-inline-expand "byte-optimize") @@ -260,7 +259,7 @@ ;; disassembler. The disassembler just requires 'byte-compile, but ;; that doesn't define this function, so this seems to be a reasonable ;; thing to do. -(autoload 'byte-decompile-bytecode "byte-opt") +(autoload 'byte-decompile-bytecode "byte-optimize") (defvar byte-compile-verbose (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) @@ -350,7 +349,7 @@ ;; byte-compile-warning-types in FSF. (defvar byte-compile-default-warnings - '(redefine callargs free-vars unresolved unused-vars obsolete) + '(redefine callargs subr-callargs free-vars unresolved unused-vars obsolete) "*The warnings used when byte-compile-warnings is t.") (defvar byte-compile-warnings t @@ -361,6 +360,7 @@ unused-vars references to non-global variables bound but not referenced. unresolved calls to unknown functions. callargs lambda calls with args that don't match the definition. + subr-callargs calls to subrs with args that don't match the definition. redefine function cell redefined from a macro to a lambda or vice versa, or redefined to take a different number of arguments. obsolete use of an obsolete function or variable. @@ -373,7 +373,7 @@ (defvar byte-compile-generate-call-tree nil "*Non-nil means collect call-graph information when compiling. -This records functions were called and from where. +This records functions that were called and from where. If the value is t, compilation displays the call graph when it finishes. If the value is neither t nor nil, compilation asks you whether to display the graph. @@ -432,6 +432,7 @@ (defvar byte-compile-free-references) (defvar byte-compile-free-assignments) +(defvar debug-issue-ebola-notices) (defvar byte-compiler-error-flag) @@ -620,7 +621,7 @@ "to examine top-of-stack, jump and don't pop it if it's nil, otherwise pop it") (byte-defop 134 -1 byte-goto-if-not-nil-else-pop - "to examine top-of-stack, jump and don't pop it if it's non nil, + "to examine top-of-stack, jump and don't pop it if it's non-nil, otherwise pop it") (byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") @@ -770,13 +771,13 @@ (error "Non-symbolic opcode `%s'" op)) ((eq op 'TAG) (setcar off pc) - (setq patchlist (cons off patchlist))) + (push off patchlist)) ((memq op byte-goto-ops) (setq pc (+ pc 3)) (setq bytes (cons (cons pc (cdr off)) (cons nil (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) + (push bytes patchlist)) (t (setq bytes (cond ((cond ((consp off) @@ -859,81 +860,64 @@ (defvar byte-compile-dest-file nil) (defmacro byte-compile-log (format-string &rest args) - (list 'and - 'byte-optimize - '(memq byte-optimize-log '(t source)) - (list 'let '((print-escape-newlines t) - (print-level 4) - (print-length 4)) - (list 'byte-compile-log-1 - (cons 'format - (cons format-string - (mapcar - '(lambda (x) - (if (symbolp x) (list 'prin1-to-string x) x)) - args))))))) - -(defconst byte-compile-last-warned-form nil) + `(when (and byte-optimize (memq byte-optimize-log '(t source))) + (let ((print-escape-newlines t) + (print-level 4) + (print-length 4)) + (byte-compile-log-1 (format ,format-string ,@args))))) + +(defconst byte-compile-last-warned-form 'nothing) ;; Log a message STRING in *Compile-Log*. ;; Also log the current function and file if not already done. (defun byte-compile-log-1 (string &optional fill) - (let ((this-form (or byte-compile-current-form "toplevel forms"))) - (cond - (noninteractive - (if (or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq this-form byte-compile-last-warned-form)))) - (message - (format "While compiling %s%s:" - this-form - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (concat " in file " byte-compile-current-file) - (concat " in buffer " - (buffer-name byte-compile-current-file))) - "")))) - (message " %s" string)) - (t - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) + (let* ((this-form (or byte-compile-current-form "toplevel forms")) + (while-compiling-msg + (when (or byte-compile-current-file + (not (eq this-form byte-compile-last-warned-form))) + (format + "While compiling %s%s:" + this-form + (cond + ((stringp byte-compile-current-file) + (concat " in file " byte-compile-current-file)) + ((bufferp byte-compile-current-file) + (concat " in buffer " + (buffer-name byte-compile-current-file))) + ("")))))) + (if noninteractive + (progn + (when while-compiling-msg (message "%s" while-compiling-msg)) + (message " %s" string)) + (with-current-buffer (get-buffer-create "*Compile-Log*") (goto-char (point-max)) - (cond ((or byte-compile-current-file - (and byte-compile-last-warned-form - (not (eq this-form byte-compile-last-warned-form)))) - (if byte-compile-current-file - (insert "\n\^L\n" (current-time-string) "\n")) - (insert "While compiling " - (if (stringp this-form) this-form - (format "%s" this-form))) - (if byte-compile-current-file - (if (stringp byte-compile-current-file) - (insert " in file " byte-compile-current-file) - (insert " in buffer " - (buffer-name byte-compile-current-file)))) - (insert ":\n"))) + (when byte-compile-current-file + (when (> (point-max) (point-min)) + (insert "\n\^L\n")) + (insert (current-time-string) "\n")) + (when while-compiling-msg (insert while-compiling-msg "\n")) (insert " " string "\n") - (if (and fill (not (string-match "\n" string))) - (let ((fill-prefix " ") - (fill-column 78)) - (fill-paragraph nil))) - ))) - (setq byte-compile-current-file nil - byte-compile-last-warned-form this-form))) + (when (and fill (not (string-match "\n" string))) + (let ((fill-prefix " ") + (fill-column 78)) + (fill-paragraph nil))))) + (setq byte-compile-current-file nil) + (setq byte-compile-last-warned-form this-form))) ;; Log the start of a file in *Compile-Log*, and mark it as done. ;; But do nothing in batch mode. (defun byte-compile-log-file () - (and byte-compile-current-file (not noninteractive) - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (goto-char (point-max)) - (insert "\n\^L\nCompiling " - (if (stringp byte-compile-current-file) - (concat "file " byte-compile-current-file) - (concat "buffer " (buffer-name byte-compile-current-file))) - " at " (current-time-string) "\n") - (setq byte-compile-current-file nil)))) + (when (and byte-compile-current-file (not noninteractive)) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (when (> (point-max) (point-min)) + (goto-char (point-max)) + (insert "\n\^L\n")) + (insert "Compiling " + (if (stringp byte-compile-current-file) + (concat "file " byte-compile-current-file) + (concat "buffer " (buffer-name byte-compile-current-file))) + " at " (current-time-string) "\n") + (setq byte-compile-current-file nil)))) (defun byte-compile-warn (format &rest args) (setq format (apply 'format format args)) @@ -987,7 +971,7 @@ (verbose byte-compile-verbose (t nil) val) (new-bytecodes byte-compile-new-bytecodes (t nil) val) (warnings byte-compile-warnings - ((callargs redefine free-vars unused-vars unresolved)) + ((callargs subr-callargs redefine free-vars unused-vars unresolved)) val))) ;; XEmacs addition @@ -1225,7 +1209,7 @@ nil) (defun byte-compile-defvar-p (var) - ;; Whether the byte compiler thinks that nonexical references to this + ;; Whether the byte compiler thinks that non-lexical references to this ;; variable are ok. (or (globally-boundp var) (let ((rest byte-compile-bound-variables)) @@ -1257,7 +1241,7 @@ ;; have (declare (ignore x)) yet; and second, inline ;; expansion produces forms like ;; ((lambda (arg) (byte-code "..." [arg])) x) - ;; which we can't (ok, well, don't) recognise as + ;; which we can't (ok, well, don't) recognize as ;; containing a reference to arg, so every inline ;; expansion would generate a warning. (If we had ;; `ignore' then inline expansion could emit an @@ -1275,12 +1259,14 @@ (setq unreferenced (cdr unreferenced))))) +(defmacro byte-compile-constant-symbol-p (symbol) + `(or (keywordp ,symbol) (memq ,symbol '(nil t)))) + (defmacro byte-compile-constp (form) ;; Returns non-nil if FORM is a constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((keywordp (, form))) - ((memq (, form) '(nil t)))))) + `(cond ((consp ,form) (eq (car ,form) 'quote)) + ((symbolp ,form) (byte-compile-constant-symbol-p ,form)) + (t))) (defmacro byte-compile-close-variables (&rest body) `(let @@ -1313,6 +1299,9 @@ byte-compile-default-warnings byte-compile-warnings)) (byte-compile-file-domain nil) + + ;; We reserve the right to compare ANY objects for equality. + (debug-issue-ebola-notices -42) ) (prog1 (progn ,@body) @@ -1321,46 +1310,49 @@ (byte-compile-warn-about-unused-variables))))) -(defvar byte-compile-warnings-point-max nil) (defmacro displaying-byte-compile-warnings (&rest body) - `(let ((byte-compile-warnings-point-max byte-compile-warnings-point-max)) - ;; Log the file name. + `(let* ((byte-compile-log-buffer (get-buffer-create "*Compile-Log*")) + (byte-compile-point-max-prev (point-max byte-compile-log-buffer))) + ;; Log the file name or buffer name. (byte-compile-log-file) ;; Record how much is logged now. ;; We will display the log buffer if anything more is logged ;; before the end of BODY. - (or byte-compile-warnings-point-max - (save-excursion - (set-buffer (get-buffer-create "*Compile-Log*")) - (setq byte-compile-warnings-point-max (point-max)))) - (unwind-protect - (condition-case error-info - (progn ,@body) - (error - (byte-compile-report-error error-info))) - (save-excursion - ;; If there were compilation warnings, display them. - (set-buffer "*Compile-Log*") - (if (= byte-compile-warnings-point-max (point-max)) - nil - (if temp-buffer-show-function - (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) - (save-excursion - (set-buffer show-buffer) - (setq buffer-read-only nil) - (erase-buffer)) - (copy-to-buffer show-buffer - (save-excursion - (goto-char byte-compile-warnings-point-max) - (forward-line -1) - (point)) - (point-max)) - (funcall temp-buffer-show-function show-buffer)) - (select-window - (prog1 (selected-window) - (select-window (display-buffer (current-buffer))) - (goto-char byte-compile-warnings-point-max) - (recenter 1))))))))) + (defvar byte-compile-warnings-beginning) + (let ((byte-compile-warnings-beginning + (if (boundp 'byte-compile-warnings-beginning) + byte-compile-warnings-beginning + (point-max byte-compile-log-buffer)))) + + (unwind-protect + (condition-case error-info + (progn ,@body) + (error + (byte-compile-report-error error-info))) + + ;; Always set point in log to start of interesting output. + (with-current-buffer byte-compile-log-buffer + (let ((show-begin + (progn (goto-char byte-compile-point-max-prev) + (skip-chars-forward "\^L\n") + (point)))) + ;; If there were compilation warnings, display them. + (if temp-buffer-show-function + (let ((show-buffer (get-buffer-create "*Compile-Log-Show*"))) + ;; Always clean show-buffer, even when not displaying it, + ;; so that misleading previous messages aren't left around. + (with-current-buffer show-buffer + (setq buffer-read-only nil) + (erase-buffer)) + (copy-to-buffer show-buffer show-begin (point-max)) + (when (< byte-compile-warnings-beginning (point-max)) + (funcall temp-buffer-show-function show-buffer))) + (when (< byte-compile-warnings-beginning (point-max)) + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char show-begin) + (recenter 1))))))))))) ;;;###autoload @@ -1466,8 +1458,6 @@ (y-or-n-p (concat "Compile " filename "? ")))))) (byte-compile-file filename)))) -(defvar kanji-flag nil) - ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -1503,7 +1493,6 @@ (message "Compiling %s..." filename)) (let (;;(byte-compile-current-file (file-name-nondirectory filename)) (byte-compile-current-file filename) - (debug-issue-ebola-notices 0) ; Hack -slb target-file input-buffer output-buffer byte-compile-dest-file) (setq target-file (byte-compile-dest-file filename)) @@ -1534,28 +1523,26 @@ (set-buffer output-buffer) (goto-char (point-max)) (insert "\n") ; aaah, unix. - (let ((vms-stmlf-recfm t)) - (setq target-file (byte-compile-dest-file filename)) - (or byte-compile-overwrite-file - (condition-case () - (delete-file target-file) - (error nil))) - (if (file-writable-p target-file) - (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki - (if (or (eq system-type 'ms-dos) (eq system-type 'windows-nt)) - (setq buffer-file-type t)) - (write-region 1 (point-max) target-file)) - ;; This is just to give a better error message than write-region - (signal 'file-error - (list "Opening output file" - (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") - target-file))) - (or byte-compile-overwrite-file - (condition-case () - (set-file-modes target-file (file-modes filename)) - (error nil)))) + (setq target-file (byte-compile-dest-file filename)) + (unless byte-compile-overwrite-file + (ignore-file-errors (delete-file target-file))) + (if (file-writable-p target-file) + (progn + (when (memq system-type '(ms-dos windows-nt)) + (defvar buffer-file-type) + (setq buffer-file-type t)) + (write-region 1 (point-max) target-file)) + ;; This is just to give a better error message than write-region + (signal 'file-error + (list "Opening output file" + (if (file-exists-p target-file) + "cannot overwrite file" + "directory not writable or nonexistent") + target-file))) + (or byte-compile-overwrite-file + (condition-case () + (set-file-modes target-file (file-modes filename)) + (error nil))) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) @@ -1664,7 +1651,7 @@ ;; Compile the forms from the input buffer. (while (progn - (while (progn (skip-chars-forward " \t\n\^l") + (while (progn (skip-chars-forward " \t\n\^L") (looking-at ";")) (forward-line 1)) (not (eobp))) @@ -1767,25 +1754,26 @@ ;; extended characters are output properly and distinguished properly. ;; Otherwise, use `no-conversion' for maximum portability with non-Mule ;; Emacsen. - (if (featurep 'mule) - (if (save-excursion - (set-buffer byte-compile-inbuffer) - (goto-char (point-min)) - ;; mrb- There must be a better way than skip-chars-forward - (skip-chars-forward (concat (char-to-string 0) "-" - (char-to-string 255))) - (eq (point) (point-max))) - (setq buffer-file-coding-system 'no-conversion) - (insert "(require 'mule)\n;;;###coding system: escape-quoted\n") - (setq buffer-file-coding-system 'escape-quoted) - ;; Lazy loading not yet implemented for MULE files - ;; mrb - Fix this someday. - (save-excursion + (when (featurep 'mule) + (defvar buffer-file-coding-system) + (if (save-excursion (set-buffer byte-compile-inbuffer) - (setq byte-compile-dynamic nil - byte-compile-dynamic-docstrings nil)) - ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) - )) + (goto-char (point-min)) + ;; mrb- There must be a better way than skip-chars-forward + (skip-chars-forward (concat (char-to-string 0) "-" + (char-to-string 255))) + (eq (point) (point-max))) + (setq buffer-file-coding-system 'no-conversion) + (insert "(require 'mule)\n;;;###coding system: escape-quoted\n") + (setq buffer-file-coding-system 'escape-quoted) + ;; #### Lazy loading not yet implemented for MULE files + ;; mrb - Fix this someday. + (save-excursion + (set-buffer byte-compile-inbuffer) + (setq byte-compile-dynamic nil + byte-compile-dynamic-docstrings nil)) + ;;(external-debugging-output (prin1-to-string (buffer-local-variables)))) + )) ) @@ -1904,8 +1892,8 @@ (nthcdr 300 byte-compile-output) (byte-compile-flush-pending)) (funcall handler form) - (if for-effect - (byte-compile-discard))) + (when for-effect + (byte-compile-discard))) (byte-compile-form form t)) nil) @@ -1939,7 +1927,7 @@ (byte-compile-file-form form))))) ;; Functions and variables with doc strings must be output separately, -;; so make-docfile can recognise them. Most other things can be output +;; so make-docfile can recognize them. Most other things can be output ;; as byte-code. (put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) @@ -2106,32 +2094,32 @@ (cons (list name nil nil) byte-compile-call-tree)))) (setq byte-compile-current-form name) ; for warnings - (if (memq 'redefine byte-compile-warnings) - (byte-compile-arglist-warn form macrop)) - (if byte-compile-verbose - (message "Compiling %s... (%s)" - ;; #### filename used free - (if filename (file-name-nondirectory filename) "") - (nth 1 form))) + (when (memq 'redefine byte-compile-warnings) + (byte-compile-arglist-warn form macrop)) + (defvar filename) ; #### filename used free + (when byte-compile-verbose + (message "Compiling %s... (%s)" + (if filename (file-name-nondirectory filename) "") + (nth 1 form))) (cond (that-one - (if (and (memq 'redefine byte-compile-warnings) - ;; hack hack: don't warn when compiling the stubs in - ;; bytecomp-runtime... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn - "%s defined multiple times, as both function and macro" - (nth 1 form))) + (when (and (memq 'redefine byte-compile-warnings) + ;; hack hack: don't warn when compiling the stubs in + ;; bytecomp-runtime... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) + (byte-compile-warn + "%s defined multiple times, as both function and macro" + (nth 1 form))) (setcdr that-one nil)) (this-one - (if (and (memq 'redefine byte-compile-warnings) - ;; hack: don't warn when compiling the magic internal - ;; byte-compiler macros in bytecomp-runtime.el... - (not (assq (nth 1 form) - byte-compile-initial-macro-environment))) - (byte-compile-warn "%s %s defined multiple times in this file" - (if macrop "macro" "function") - (nth 1 form)))) + (when (and (memq 'redefine byte-compile-warnings) + ;; hack: don't warn when compiling the magic internal + ;; byte-compiler macros in bytecomp-runtime.el... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) + (byte-compile-warn "%s %s defined multiple times in this file" + (if macrop "macro" "function") + (nth 1 form)))) ((and (fboundp name) (or (subrp (symbol-function name)) (eq (car-safe (symbol-function name)) @@ -2145,8 +2133,7 @@ (if macrop "macro" "function"))) ;; shadow existing definition (set this-kind - (cons (cons name nil) (symbol-value this-kind)))) - ) + (cons (cons name nil) (symbol-value this-kind))))) (let ((body (nthcdr 3 form))) (if (and (stringp (car body)) (symbolp (car-safe (cdr-safe body))) @@ -2345,11 +2332,11 @@ (let* ((interactive (assq 'interactive (cdr (cdr fun))))) (nconc (list 'make-byte-code (list 'quote (nth 1 fun)) ;arglist - (nth 1 tmp) ;bytes - (nth 2 tmp) ;consts - (nth 3 tmp)) ;depth + (nth 1 tmp) ;instructions + (nth 2 tmp) ;constants + (nth 3 tmp)) ;stack-depth (cond ((stringp (nth 2 fun)) - (list (nth 2 fun))) ;doc + (list (nth 2 fun))) ;docstring (interactive (list nil))) (cond (interactive @@ -2371,8 +2358,7 @@ (let* ((arglist (nth 1 fun)) (byte-compile-bound-variables (let ((new-bindings - (mapcar (function (lambda (x) - (cons x byte-compile-arglist-bit))) + (mapcar #'(lambda (x) (cons x byte-compile-arglist-bit)) (and (memq 'free-vars byte-compile-warnings) (delq '&rest (delq '&optional (copy-sequence arglist))))))) @@ -2383,18 +2369,16 @@ (prog1 (car body) (setq body (cdr body))))) (int (assq 'interactive body))) - (let ((rest arglist)) - (while rest - (cond ((not (symbolp (car rest))) - (byte-compile-warn "non-symbol in arglist: %s" - (prin1-to-string (car rest)))) - ((memq (car rest) '(t nil)) - (byte-compile-warn "constant in arglist: %s" (car rest))) - ((and (char= ?\& (aref (symbol-name (car rest)) 0)) - (not (memq (car rest) '(&optional &rest)))) - (byte-compile-warn "unrecognised `&' keyword in arglist: %s" - (car rest)))) - (setq rest (cdr rest)))) + (dolist (arg arglist) + (cond ((not (symbolp arg)) + (byte-compile-warn "non-symbol in arglist: %S" arg)) + ((byte-compile-constant-symbol-p arg) + (byte-compile-warn "constant symbol in arglist: %s" arg)) + ((and (char= ?\& (aref (symbol-name arg) 0)) + (not (eq arg '&optional)) + (not (eq arg '&rest))) + (byte-compile-warn "unrecognized `&' keyword in arglist: %s" + arg)))) (cond (int ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) @@ -2555,8 +2539,7 @@ (if (if (eq (car (car rest)) 'byte-constant) (or (consp tmp) (and (symbolp tmp) - (not (keywordp tmp)) - (not (memq tmp '(nil t)))))) + (not (byte-compile-constant-symbol-p tmp))))) (if maycall (setq body (cons (list 'quote tmp) body))) (setq body (cons tmp body)))) @@ -2606,7 +2589,7 @@ ;; This is the recursive entry point for compiling each subform of an ;; expression. ;; If for-effect is non-nil, byte-compile-form will output a byte-discard -;; before terminating (ie no value will be left on the stack). +;; before terminating (ie. no value will be left on the stack). ;; A byte-compile handler may, when for-effect is non-nil, choose output code ;; which does not leave a value on the stack, and then set for-effect to nil ;; (to prevent byte-compile-form from outputting the byte-discard). @@ -2617,8 +2600,8 @@ (defun byte-compile-form (form &optional for-effect) (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) - ;; XEmacs addition: keywordp - (cond ((or (not (symbolp form)) (keywordp form) (memq form '(nil t))) + (cond ((or (not (symbolp form)) + (byte-compile-constant-symbol-p form)) (byte-compile-constant form)) ((and for-effect byte-compile-delete-errors) (setq for-effect nil)) @@ -2644,8 +2627,8 @@ (byte-compile-form form for-effect) (setq for-effect nil)) ((byte-compile-normal-call form))) - (if for-effect - (byte-compile-discard))) + (when for-effect + (byte-compile-discard))) (defun byte-compile-normal-call (form) (if byte-compile-generate-call-tree @@ -2658,12 +2641,14 @@ (or (fboundp 'globally-boundp) (fset 'globally-boundp 'boundp)) (defun byte-compile-variable-ref (base-op var &optional varbind-flags) - (if (or (not (symbolp var)) (keywordp var) (memq var '(nil t))) - (byte-compile-warn (if (eq base-op 'byte-varbind) - "Attempt to let-bind %s %s" - "Variable reference to %s %s") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)) + (if (or (not (symbolp var)) (byte-compile-constant-symbol-p var)) + (byte-compile-warn + (case base-op + (byte-varref "Variable reference to %s %s") + (byte-varset "Attempt to set %s %s") + (byte-varbind "Attempt to let-bind %s %s")) + (if (symbolp var) "constant symbol" "non-symbol") + var) (if (and (get var 'byte-obsolete-variable) (memq 'obsolete byte-compile-warnings)) (let ((ob (get var 'byte-obsolete-variable))) @@ -2709,11 +2694,11 @@ (byte-compile-out base-op tmp))) (defmacro byte-compile-get-constant (const) - (` (or (if (stringp (, const)) - (assoc (, const) byte-compile-constants) - (assq (, const) byte-compile-constants)) - (car (setq byte-compile-constants - (cons (list (, const)) byte-compile-constants)))))) + `(or (if (stringp ,const) + (assoc ,const byte-compile-constants) + (assq ,const byte-compile-constants)) + (car (setq byte-compile-constants + (cons (list ,const) byte-compile-constants))))) ;; Use this when the value of a form is a constant. This obeys for-effect. (defun byte-compile-constant (const) @@ -2894,12 +2879,6 @@ (byte-defop-compiler20 old-memq 2) (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) -(byte-defop-compiler (= byte-eqlsign) byte-compile-one-or-more-args) -(byte-defop-compiler (< byte-lss) byte-compile-one-or-more-args) -(byte-defop-compiler (> byte-gtr) byte-compile-one-or-more-args) -(byte-defop-compiler (<= byte-leq) byte-compile-one-or-more-args) -(byte-defop-compiler (>= byte-geq) byte-compile-one-or-more-args) -(byte-defop-compiler /= byte-compile-/=) (byte-defop-compiler get 2+1) (byte-defop-compiler nth 2) (byte-defop-compiler substring 2-3) @@ -2922,9 +2901,6 @@ (byte-defop-compiler (rplacd byte-setcdr) 2) (byte-defop-compiler setcar 2) (byte-defop-compiler setcdr 2) -;; buffer-substring now has its own function. This used to be -;; 2+1, but now all args are optional. -(byte-defop-compiler buffer-substring) (byte-defop-compiler delete-region 2+1) (byte-defop-compiler narrow-to-region 2+1) (byte-defop-compiler (% byte-rem) 2) @@ -2954,55 +2930,56 @@ (defun byte-compile-subr-wrong-args (form n) - (byte-compile-warn "%s called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) + (when (memq 'subr-callargs byte-compile-warnings) + (byte-compile-warn "%s called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n)) ;; get run-time wrong-number-of-args error. (byte-compile-normal-call form)) (defun byte-compile-no-args (form) - (if (not (= (length form) 1)) - (byte-compile-subr-wrong-args form "none") - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (0 (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form "none")))) (defun byte-compile-one-arg (form) - (if (not (= (length form) 2)) - (byte-compile-subr-wrong-args form 1) - (byte-compile-form (car (cdr form))) ;; Push the argument - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (1 (byte-compile-form (car (cdr form))) ;; Push the argument + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 1)))) (defun byte-compile-two-args (form) - (if (not (= (length form) 3)) - (byte-compile-subr-wrong-args form 2) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (2 (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 2)))) (defun byte-compile-three-args (form) - (if (not (= (length form) 4)) - (byte-compile-subr-wrong-args form 3) - (byte-compile-form (car (cdr form))) ;; Push the arguments - (byte-compile-form (nth 2 form)) - (byte-compile-form (nth 3 form)) - (byte-compile-out (get (car form) 'byte-opcode) 0))) + (case (length (cdr form)) + (3 (byte-compile-form (nth 1 form)) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-form (nth 3 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (t (byte-compile-subr-wrong-args form 3)))) (defun byte-compile-zero-or-one-arg (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) + (case (length (cdr form)) + (0 (byte-compile-one-arg (append form '(nil)))) + (1 (byte-compile-one-arg form)) + (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-one-or-two-args (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) + (case (length (cdr form)) + (1 (byte-compile-two-args (append form '(nil)))) + (2 (byte-compile-two-args form)) + (t (byte-compile-subr-wrong-args form "1-2")))) (defun byte-compile-two-or-three-args (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) + (case (length (cdr form)) + (2 (byte-compile-three-args (append form '(nil)))) + (3 (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "2-3")))) ;; from Ben Wing : some inlined functions have extra ;; optional args added to them in XEmacs 19.12. Changing the byte @@ -3013,55 +2990,55 @@ ;; `byte-compile-subr-wrong-args' also converts the call to non-inlined. (defun byte-compile-no-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-no-args form)) - ((= len 2) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-1"))))) + (case (length (cdr form)) + (0 (byte-compile-no-args form)) + (1 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-1")))) (defun byte-compile-one-arg-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-one-arg form)) - ((= len 3) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-2"))))) + (case (length (cdr form)) + (1 (byte-compile-one-arg form)) + (2 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-2")))) (defun byte-compile-two-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "2-3"))))) + (case (length (cdr form)) + (2 (byte-compile-two-args form)) + (3 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "2-3")))) (defun byte-compile-zero-or-one-arg-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) - ((= len 2) (byte-compile-one-arg form)) - ((= len 3) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-2"))))) + (case (length (cdr form)) + (0 (byte-compile-one-arg (append form '(nil)))) + (1 (byte-compile-one-arg form)) + (2 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-2")))) (defun byte-compile-one-or-two-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) - ((= len 3) (byte-compile-two-args form)) - ((= len 4) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-3"))))) + (case (length (cdr form)) + (1 (byte-compile-two-args (append form '(nil)))) + (2 (byte-compile-two-args form)) + (3 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-3")))) (defun byte-compile-two-or-three-args-with-one-extra (form) - (let ((len (length form))) - (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) - ((= len 4) (byte-compile-three-args form)) - ((= len 5) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "2-4"))))) + (case (length (cdr form)) + (2 (byte-compile-three-args (append form '(nil)))) + (3 (byte-compile-three-args form)) + (4 (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "2-4")))) (defun byte-compile-no-args-with-two-extra (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-no-args form)) - ((or (= len 2) (= len 3)) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "0-2"))))) + (case (length (cdr form)) + (0 (byte-compile-no-args form)) + ((1 2) (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "0-2")))) (defun byte-compile-one-arg-with-two-extra (form) - (let ((len (length form))) - (cond ((= len 2) (byte-compile-one-arg form)) - ((or (= len 3) (= len 4)) (byte-compile-normal-call form)) - (t (byte-compile-subr-wrong-args form "1-3"))))) + (case (length (cdr form)) + (1 (byte-compile-one-arg form)) + ((2 3) (byte-compile-normal-call form)) + (t (byte-compile-subr-wrong-args form "1-3")))) ;; XEmacs: used for functions that have a different opcode in v19 than v20. ;; this includes `eq', `equal', and other old-ified functions. @@ -3080,21 +3057,33 @@ (defun byte-compile-discard () (byte-compile-out 'byte-discard 0)) +;; Compile a function that accepts one or more args and is right-associative. +;; We do it by left-associativity so that the operations +;; are done in the same order as in interpreted code. +;(defun byte-compile-associative (form) +; (if (cdr form) +; (let ((opcode (get (car form) 'byte-opcode)) +; (args (copy-sequence (cdr form)))) +; (byte-compile-form (car args)) +; (setq args (cdr args)) +; (while args +; (byte-compile-form (car args)) +; (byte-compile-out opcode 0) +; (setq args (cdr args)))) +; (byte-compile-constant (eval form)))) ;; Compile a function that accepts one or more args and is right-associative. ;; We do it by left-associativity so that the operations ;; are done in the same order as in interpreted code. (defun byte-compile-associative (form) - (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - (args (copy-sequence (cdr form)))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (while args - (byte-compile-form (car args)) - (byte-compile-out opcode 0) - (setq args (cdr args)))) - (byte-compile-constant (eval form)))) + (let ((args (cdr form)) + (opcode (get (car form) 'byte-opcode))) + (case (length args) + (0 (byte-compile-constant (eval form))) + (t (byte-compile-form (car args)) + (dolist (arg (cdr args)) + (byte-compile-form arg) + (byte-compile-out opcode 0)))))) ;; more complicated compiler macros @@ -3109,20 +3098,32 @@ (byte-defop-compiler nconc) (byte-defop-compiler-1 beginning-of-line) -(defun byte-compile-one-or-more-args (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) - ((= len 2) (byte-compile-constant t)) - ((= len 3) (byte-compile-two-args form)) - (t (byte-compile-normal-call form))))) +(byte-defop-compiler (= byte-eqlsign) byte-compile-arithcompare) +(byte-defop-compiler (< byte-lss) byte-compile-arithcompare) +(byte-defop-compiler (> byte-gtr) byte-compile-arithcompare) +(byte-defop-compiler (<= byte-leq) byte-compile-arithcompare) +(byte-defop-compiler (>= byte-geq) byte-compile-arithcompare) + +(defun byte-compile-arithcompare (form) + (case (length (cdr form)) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant t)) + (2 (byte-compile-two-args form)) + (t (byte-compile-normal-call form)))) + +(byte-defop-compiler /= byte-compile-/=) (defun byte-compile-/= (form) - (let ((len (length form))) - (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more")) - ((= len 2) (byte-compile-constant t)) - ;; optimize (/= X Y) to (not (= X Y)) - ((= len 3) (byte-compile-form-do-effect `(not (= ,@(cdr form))))) - (t (byte-compile-normal-call form))))) + (case (length (cdr form)) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant t)) + ;; optimize (/= X Y) to (not (= X Y)) + (2 (byte-compile-form-do-effect `(not (= ,@(cdr form))))) + (t (byte-compile-normal-call form)))) + +;; buffer-substring now has its own function. This used to be +;; 2+1, but now all args are optional. +(byte-defop-compiler buffer-substring) (defun byte-compile-buffer-substring (form) ;; buffer-substring used to take exactly two args, but now takes 0-3. @@ -3136,65 +3137,71 @@ (t (byte-compile-subr-wrong-args form "0-3")))) (defun byte-compile-list (form) - (let ((count (length (cdr form)))) - (cond ((= count 0) - (byte-compile-constant nil)) - ((< count 5) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) - ((< count 256) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-listN count)) - (t (byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args))) + (cond + ((= nargs 0) + (byte-compile-constant nil)) + ((< nargs 5) + (mapcar 'byte-compile-form args) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs)) + 0)) + ((< nargs 256) + (mapcar 'byte-compile-form args) + (byte-compile-out 'byte-listN nargs)) + (t (byte-compile-normal-call form))))) (defun byte-compile-concat (form) - (let ((count (length (cdr form)))) - (cond ((and (< 1 count) (< count 5)) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out - (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) - 0)) - ;; Concat of one arg is not a no-op if arg is not a string. - ((= count 0) - (byte-compile-form "")) - ((< count 256) - (mapcar 'byte-compile-form (cdr form)) - (byte-compile-out 'byte-concatN count)) - ((byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args))) + ;; Concat of one arg is not a no-op if arg is not a string. + (cond + ((memq nargs '(2 3 4)) + (mapcar 'byte-compile-form args) + (byte-compile-out + (aref [byte-concat2 byte-concat3 byte-concat4] (- nargs 2)) + 0)) + ((eq nargs 0) + (byte-compile-form "")) + ((< nargs 256) + (mapcar 'byte-compile-form args) + (byte-compile-out 'byte-concatN nargs)) + ((byte-compile-normal-call form))))) (defun byte-compile-minus (form) - (if (null (setq form (cdr form))) - (byte-compile-constant 0) - (byte-compile-form (car form)) - (if (cdr form) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-diff 0)) - (byte-compile-out 'byte-negate 0)))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-form (car args)) + (byte-compile-out 'byte-negate 0)) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-diff 0)))))) (defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((<= len 2) - (byte-compile-subr-wrong-args form "2 or more")) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-quo 0)))))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-subr-wrong-args form "1 or more")) + (1 (byte-compile-constant 1) + (byte-compile-form (car args)) + (byte-compile-out 'byte-quo 0)) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-quo 0)))))) (defun byte-compile-nconc (form) - (let ((len (length form))) - (cond ((= len 1) - (byte-compile-constant nil)) - ((= len 2) - ;; nconc of one arg is a noop, even if that arg isn't a list. - (byte-compile-form (nth 1 form))) - (t - (byte-compile-form (car (setq form (cdr form)))) - (while (setq form (cdr form)) - (byte-compile-form (car form)) - (byte-compile-out 'byte-nconc 0)))))) + (let ((args (cdr form))) + (case (length args) + (0 (byte-compile-constant nil)) + ;; nconc of one arg is a noop, even if that arg isn't a list. + (1 (byte-compile-form (car args))) + (t (byte-compile-form (car args)) + (dolist (elt (cdr args)) + (byte-compile-form elt) + (byte-compile-out 'byte-nconc 0)))))) (defun byte-compile-fset (form) ;; warn about forms like (fset 'foo '(lambda () ...)) @@ -3203,19 +3210,18 @@ ;; I'm sick of getting mail asking me whether that warning is a problem. (let ((fn (nth 2 form)) body) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (setq fn (nth 1 fn))) 'lambda) - (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) - (progn - (setq body (cdr (cdr fn))) - (if (stringp (car body)) (setq body (cdr body))) - (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) - (if (and (consp (car body)) - (not (eq 'byte-code (car (car body))))) - (byte-compile-warn - "A quoted lambda form is the second argument of fset. This is probably + (when (and (eq (car-safe fn) 'quote) + (eq (car-safe (setq fn (nth 1 fn))) 'lambda) + (not (eq (car-safe (cdr-safe (nth 1 form))) 'make-byte-code))) + (setq body (cdr (cdr fn))) + (if (stringp (car body)) (setq body (cdr body))) + (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) + (if (and (consp (car body)) + (not (eq 'byte-code (car (car body))))) + (byte-compile-warn + "A quoted lambda form is the second argument of fset. This is probably not what you want, as that lambda cannot be compiled. Consider using - the syntax (function (lambda (...) ...)) instead."))))) + the syntax (function (lambda (...) ...)) instead.")))) (byte-compile-two-args form)) (defun byte-compile-funarg (form) @@ -3255,8 +3261,8 @@ (while (setq form (cdr form)) (byte-compile-form (car form)) (byte-compile-out 'byte-insert 0) - (if (cdr form) - (byte-compile-discard)))))) + (when (cdr form) + (byte-compile-discard)))))) ;; alas, the old (pre-19.12, and all existing versions of FSFmacs 19) ;; byte compiler will generate incorrect code for @@ -3290,76 +3296,82 @@ (byte-defop-compiler-1 quote-form) (defun byte-compile-setq (form) - (let ((args (cdr form))) - (if args - (while args - (byte-compile-form (car (cdr args))) - (or for-effect (cdr (cdr args)) + (let ((args (cdr form)) var val) + (if (null args) + ;; (setq), with no arguments. + (byte-compile-form nil for-effect) + (while args + (setq var (pop args)) + (if (null args) + ;; Odd number of args? Let `set' get the error. + (byte-compile-form `(set ',var) for-effect) + (setq val (pop args)) + (if (keywordp var) + ;; (setq :foo ':foo) compatibility kludge + (byte-compile-form `(set ',var ,val) (if args t for-effect)) + (byte-compile-form val) + (unless (or args for-effect) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car args)) - (setq args (cdr (cdr args)))) - ;; (setq), with no arguments. - (byte-compile-form nil for-effect)) - (setq for-effect nil))) + (byte-compile-variable-ref 'byte-varset var)))))) + (setq for-effect nil)) (defun byte-compile-set (form) ;; Compile (set 'foo x) as (setq foo x) for trivially better code and so ;; that we get applicable warnings. Compile everything else (including ;; malformed calls) like a normal 2-arg byte-coded function. - (if (or (not (eq (car-safe (nth 1 form)) 'quote)) - (not (= (length form) 3)) - (not (= (length (nth 1 form)) 2))) - (byte-compile-two-args form) - (byte-compile-setq (list 'setq (nth 1 (nth 1 form)) (nth 2 form))))) + (let ((symform (nth 1 form)) + (valform (nth 2 form)) + sym) + (if (and (= (length form) 3) + (= (safe-length symform) 2) + (eq (car symform) 'quote) + (symbolp (setq sym (car (cdr symform)))) + (not (byte-compile-constant-symbol-p sym))) + (byte-compile-setq `(setq ,sym ,valform)) + (byte-compile-two-args form)))) (defun byte-compile-setq-default (form) - (let ((rest (cdr form))) - ;; emit multiple calls to set-default if necessary - (while rest - (byte-compile-form - (list 'set-default (list 'quote (car rest)) (car (cdr rest))) - (not (null (cdr (cdr rest))))) - (setq rest (cdr (cdr rest)))))) + (let ((args (cdr form))) + (if (null args) + ;; (setq-default), with no arguments. + (byte-compile-form nil for-effect) + ;; emit multiple calls to `set-default' if necessary + (while args + (byte-compile-form + ;; Odd number of args? Let `set-default' get the error. + `(set-default ',(pop args) ,@(if args (list (pop args)) nil)) + (if args t for-effect))))) + (setq for-effect nil)) + (defun byte-compile-set-default (form) - (let ((rest (cdr form))) - (if (cdr (cdr (cdr form))) - ;; emit multiple calls to set-default if necessary; all but last - ;; for-effect (this recurses.) - (while rest - (byte-compile-form - (list 'set-default (car rest) (car (cdr rest))) - (not (null (cdr rest)))) - (setq rest (cdr (cdr rest)))) - ;; else, this is the one-armed version - (let ((var (nth 1 form)) - ;;(val (nth 2 form)) - ) - ;; notice calls to set-default/setq-default for variables which - ;; have not been declared with defvar/defconst. - (if (and (memq 'free-vars byte-compile-warnings) - (or (null var) - (and (eq (car-safe var) 'quote) - (= 2 (length var))))) - (let ((sym (nth 1 var)) - cell) - (or (and sym (symbolp sym) (globally-boundp sym)) - (and (setq cell (assq sym byte-compile-bound-variables)) - (setcdr cell (logior (cdr cell) - byte-compile-assigned-bit))) - (memq sym byte-compile-free-assignments) - (if (or (not (symbolp sym)) (memq sym '(t nil))) - (progn - (byte-compile-warn - "Attempt to set-globally %s %s" - (if (symbolp sym) "constant" "nonvariable") - (prin1-to-string sym))) - (progn - (byte-compile-warn "assignment to free variable %s" sym) - (setq byte-compile-free-assignments - (cons sym byte-compile-free-assignments))))))) - ;; now emit a normal call to set-default (or possibly multiple calls) - (byte-compile-normal-call form))))) + (let* ((args (cdr form)) + (nargs (length args)) + (var (car args))) + (when (and (= (safe-length var) 2) + (eq (car var) 'quote)) + (let ((sym (nth 1 var))) + (cond + ((not (symbolp sym)) + (byte-compile-warn "Attempt to set-globally non-symbol %s" sym)) + ((byte-compile-constant-symbol-p sym) + (byte-compile-warn "Attempt to set-globally constant symbol %s" sym)) + ((let ((cell (assq sym byte-compile-bound-variables))) + (and cell + (setcdr cell (logior (cdr cell) byte-compile-assigned-bit)) + t))) + ;; notice calls to set-default/setq-default for variables which + ;; have not been declared with defvar/defconst. + ((globally-boundp sym)) ; OK + ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed? + ((memq sym byte-compile-free-assignments)) ; already warned about sym + (t + (byte-compile-warn "assignment to free variable %s" sym) + (push sym byte-compile-free-assignments))))) + (if (= nargs 2) + ;; now emit a normal call to set-default + (byte-compile-normal-call form) + (byte-compile-subr-wrong-args form 2)))) (defun byte-compile-quote (form) @@ -3408,20 +3420,22 @@ (byte-compile-body-do-effect (cdr form))) (defun byte-compile-prog1 (form) - (byte-compile-form-do-effect (car (cdr form))) - (byte-compile-body (cdr (cdr form)) t)) + (setq form (cdr form)) + (byte-compile-form-do-effect (pop form)) + (byte-compile-body form t)) (defun byte-compile-prog2 (form) - (byte-compile-form (nth 1 form) t) - (byte-compile-form-do-effect (nth 2 form)) - (byte-compile-body (cdr (cdr (cdr form))) t)) + (setq form (cdr form)) + (byte-compile-form (pop form) t) + (byte-compile-form-do-effect (pop form)) + (byte-compile-body form t)) (defmacro byte-compile-goto-if (cond discard tag) - (` (byte-compile-goto - (if (, cond) - (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) - (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) - (, tag)))) + `(byte-compile-goto + (if ,cond + (if ,discard 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) + (if ,discard 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) + ,tag)) (defun byte-compile-if (form) (byte-compile-form (car (cdr form))) @@ -3827,7 +3841,7 @@ (defun byte-compile-out-tag (tag) - (setq byte-compile-output (cons tag byte-compile-output)) + (push tag byte-compile-output) (if (cdr (cdr tag)) (progn ;; ## remove this someday @@ -3838,7 +3852,7 @@ (setcdr (cdr tag) byte-compile-depth))) (defun byte-compile-goto (opcode tag) - (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) + (push (cons opcode tag) byte-compile-output) (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) (1- byte-compile-depth) byte-compile-depth)) @@ -3846,20 +3860,21 @@ (1- byte-compile-depth)))) (defun byte-compile-out (opcode offset) - (setq byte-compile-output (cons (cons opcode offset) byte-compile-output)) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) + (push (cons opcode offset) byte-compile-output) + (case opcode + (byte-call + (setq byte-compile-depth (- byte-compile-depth offset))) + (byte-return + ;; This is actually an unnecessary case, because there should be + ;; no more opcodes behind byte-return. + (setq byte-compile-depth nil)) + (t + (setq byte-compile-depth (+ byte-compile-depth + (or (aref byte-stack+-info + (symbol-value opcode)) + (- (1- offset)))) + byte-compile-maxdepth (max byte-compile-depth + byte-compile-maxdepth)))) ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) ) @@ -3873,18 +3888,15 @@ (or (memq byte-compile-current-form (nth 1 entry)) ;callers (setcar (cdr entry) (cons byte-compile-current-form (nth 1 entry)))) - (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) - byte-compile-call-tree))) + (push (list (car form) (list byte-compile-current-form) nil) + byte-compile-call-tree)) ;; annotate the current function (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) (or (memq (car form) (nth 2 entry)) ;called (setcar (cdr (cdr entry)) (cons (car form) (nth 2 entry)))) - (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (push (list byte-compile-current-form nil (list (car form))) + byte-compile-call-tree)))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -3923,19 +3935,19 @@ (sort byte-compile-call-tree (cond ((eq byte-compile-call-tree-sort 'callers) - (function (lambda (x y) (< (length (nth 1 x)) - (length (nth 1 y)))))) + #'(lambda (x y) (< (length (nth 1 x)) + (length (nth 1 y))))) ((eq byte-compile-call-tree-sort 'calls) - (function (lambda (x y) (< (length (nth 2 x)) - (length (nth 2 y)))))) + #'(lambda (x y) (< (length (nth 2 x)) + (length (nth 2 y))))) ((eq byte-compile-call-tree-sort 'calls+callers) - (function (lambda (x y) (< (+ (length (nth 1 x)) - (length (nth 2 x))) - (+ (length (nth 1 y)) - (length (nth 2 y))))))) + #'(lambda (x y) (< (+ (length (nth 1 x)) + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y)))))) ((eq byte-compile-call-tree-sort 'name) - (function (lambda (x y) (string< (car x) - (car y))))) + #'(lambda (x y) (string< (car x) + (car y)))) (t (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" byte-compile-call-tree-sort)))))) @@ -4031,8 +4043,7 @@ (defvar command-line-args-left) ;Avoid 'free variable' warning (if (not noninteractive) (error "`batch-byte-compile' is to be used only with -batch")) - (let ((error nil) - (debug-issue-ebola-notices 0)) ; Hack -slb + (let ((error nil)) (while command-line-args-left (if (file-directory-p (expand-file-name (car command-line-args-left))) (let ((files (directory-files (car command-line-args-left))) @@ -4065,7 +4076,7 @@ (if (fboundp 'display-error) ; XEmacs 19.8+ (display-error err nil) (princ (or (get (car err) 'error-message) (car err))) - (mapcar '(lambda (x) (princ " ") (prin1 x)) (cdr err))) + (mapcar #'(lambda (x) (princ " ") (prin1 x)) (cdr err))) (princ "\n") nil))) @@ -4086,8 +4097,7 @@ (error "batch-byte-recompile-directory is to be used only with -batch")) (or command-line-args-left (setq command-line-args-left '("."))) - (let ((byte-recompile-directory-ignore-errors-p t) - (debug-issue-ebola-notices 0)) + (let ((byte-recompile-directory-ignore-errors-p t)) (while command-line-args-left (byte-recompile-directory (car command-line-args-left)) (setq command-line-args-left (cdr command-line-args-left)))) @@ -4140,10 +4150,10 @@ (assq 'byte-code (symbol-function 'byte-compile-form)) (let ((byte-optimize nil) ; do it fast (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (mapcar #'(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) '(byte-compile-normal-call byte-compile-form byte-compile-body diff -r 76b7d63099ad -r 8626e4521993 lisp/callers-of-rpt.el --- a/lisp/callers-of-rpt.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/callers-of-rpt.el Mon Aug 13 11:07:10 2007 +0200 @@ -40,8 +40,8 @@ "Where the package lisp sources live.") ;; (makunbound 'caller-table) -(defconst caller-table (make-hashtable 256 #'equal) - "Hashtable keyed on the symbols being required. Each element will +(defconst caller-table (make-hash-table :test 'equal) + "Hash table keyed on the symbols being required. Each element will be a list of file-names of programs that depend on them.") ;;./apel/atype.el:(require 'emu) @@ -91,7 +91,8 @@ (point)) cmd-out)) (lst (gethash key caller-table))) - (puthash key (add-to-list 'lst file-name) caller-table)) + (unless (member file-name lst) + (puthash key (cons file-name lst) caller-table))) (forward-line 1) (sit-for 0)) (switch-to-buffer rpt) diff -r 76b7d63099ad -r 8626e4521993 lisp/cl-extra.el --- a/lisp/cl-extra.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/cl-extra.el Mon Aug 13 11:07:10 2007 +0200 @@ -48,6 +48,8 @@ ;;; Code: +(eval-when-compile + (require 'obsolete)) (or (memq 'cl-19 features) (error "Tried to load `cl-extra' before `cl'!")) @@ -468,7 +470,7 @@ ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. (let ((vec (aref state 3))) (if (integerp vec) - (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1) ii) + (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) (aset state 3 (setq vec (make-vector 55 nil))) (aset vec 0 j) (while (> (setq i (% (+ i 21) 55)) 0) @@ -502,7 +504,7 @@ ;; Implementation limits. (defun cl-finite-do (func a b) - (condition-case err + (condition-case nil (let ((res (funcall func a b))) ; check for IEEE infinity (and (numberp res) (/= res (/ res 2)) res)) (arith-error nil))) @@ -531,14 +533,14 @@ most-negative-float (- x)) ;; Divide down until mantissa starts rounding. (setq x (/ x z) y (/ 16 z) x (* x y)) - (while (condition-case err (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) + (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) (arith-error nil)) (setq x (/ x 2) y (/ y 2))) (setq least-positive-normalized-float y least-negative-normalized-float (- y)) ;; Divide down until value underflows to zero. (setq x (/ 1 z) y x) - (while (condition-case err (> (/ x 2) 0) (arith-error nil)) + (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) (setq x (/ x 2))) (setq least-positive-float x least-negative-float (- x)) @@ -581,11 +583,11 @@ (defun concatenate (type &rest seqs) "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." - (cond ((eq type 'vector) (apply 'vconcat seqs)) - ((eq type 'string) (apply 'concat seqs)) - ((eq type 'list) (apply 'append (append seqs '(nil)))) - (t (error "Not a sequence type name: %s" type)))) - + (case type + (vector (apply 'vconcat seqs)) + (string (apply 'concat seqs)) + (list (apply 'append (append seqs '(nil)))) + (t (error "Not a sequence type name: %s" type)))) ;;; List functions. @@ -666,142 +668,43 @@ ;;; 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)))) +;; 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)) -(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)) +(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) -(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) +(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) -(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) +(when (fboundp 'x-keysym-hash-table) + (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) -(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) +;; 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)) -(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))) - +(defalias 'cl-gethash 'gethash) +(defalias 'cl-puthash 'puthash) +(defalias 'cl-remhash 'remhash) +(defalias 'cl-clrhash 'clrhash) +(defalias 'cl-maphash 'maphash) ;;; Some debugging aids. diff -r 76b7d63099ad -r 8626e4521993 lisp/cl-macs.el --- a/lisp/cl-macs.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/cl-macs.el Mon Aug 13 11:07:10 2007 +0200 @@ -78,9 +78,9 @@ (or (fboundp 'defalias) (fset 'defalias 'fset)) (or (fboundp 'cl-transform-function-property) (defalias 'cl-transform-function-property - (function (lambda (n p f) - (list 'put (list 'quote n) (list 'quote p) - (list 'function (cons 'lambda f))))))) + #'(lambda (n p f) + (list 'put (list 'quote n) (list 'quote p) + (list 'function (cons 'lambda f)))))) (car (or features (setq features (list 'cl-kludge)))))) @@ -97,12 +97,11 @@ (setq cl-old-bc-file-form (symbol-function 'byte-compile-file-form)) (or (fboundp 'byte-compile-flush-pending) ; Emacs 19 compiler? (defalias 'byte-compile-file-form - (function - (lambda (form) - (setq form (macroexpand form byte-compile-macro-environment)) - (if (eq (car-safe form) 'progn) - (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) - (funcall cl-old-bc-file-form form)))))) + #'(lambda (form) + (setq form (macroexpand form byte-compile-macro-environment)) + (if (eq (car-safe form) 'progn) + (cons 'progn (mapcar 'byte-compile-file-form (cdr form))) + (funcall cl-old-bc-file-form form))))) (put 'eql 'byte-compile 'cl-byte-compile-compiler-macro) (run-hooks 'cl-hack-bytecomp-hook)) @@ -455,27 +454,26 @@ (body (cons 'cond (mapcar - (function - (lambda (c) - (cons (cond ((memq (car c) '(t otherwise)) - (or (eq c last-clause) - (error - "`%s' is allowed only as the last case clause" - (car c))) - t) - ((eq (car c) 'ecase-error-flag) - (list 'error "ecase failed: %s, %s" - temp (list 'quote (reverse head-list)))) - ((listp (car c)) - (setq head-list (append (car c) head-list)) - (list 'member* temp (list 'quote (car c)))) - (t - (if (memq (car c) head-list) - (error "Duplicate key in case: %s" - (car c))) - (cl-push (car c) head-list) - (list 'eql temp (list 'quote (car c))))) - (or (cdr c) '(nil))))) + #'(lambda (c) + (cons (cond ((memq (car c) '(t otherwise)) + (or (eq c last-clause) + (error + "`%s' is allowed only as the last case clause" + (car c))) + t) + ((eq (car c) 'ecase-error-flag) + (list 'error "ecase failed: %s, %s" + temp (list 'quote (reverse head-list)))) + ((listp (car c)) + (setq head-list (append (car c) head-list)) + (list 'member* temp (list 'quote (car c)))) + (t + (if (memq (car c) head-list) + (error "Duplicate key in case: %s" + (car c))) + (cl-push (car c) head-list) + (list 'eql temp (list 'quote (car c))))) + (or (cdr c) '(nil)))) clauses)))) (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) @@ -507,16 +505,15 @@ (body (cons 'cond (mapcar - (function - (lambda (c) - (cons (cond ((eq (car c) 'otherwise) t) - ((eq (car c) 'ecase-error-flag) - (list 'error "etypecase failed: %s, %s" - temp (list 'quote (reverse type-list)))) - (t - (cl-push (car c) type-list) - (cl-make-type-test temp (car c)))) - (or (cdr c) '(nil))))) + #'(lambda (c) + (cons (cond ((eq (car c) 'otherwise) t) + ((eq (car c) 'ecase-error-flag) + (list 'error "etypecase failed: %s, %s" + temp (list 'quote (reverse type-list)))) + (t + (cl-push (car c) type-list) + (cl-make-type-test temp (car c)))) + (or (cdr c) '(nil)))) clauses)))) (if (eq temp expr) body (list 'let (list (list temp expr)) body)))) @@ -1165,16 +1162,14 @@ (defun cl-expand-do-loop (steps endtest body star) (list 'block nil (list* (if star 'let* 'let) - (mapcar (function (lambda (c) - (if (consp c) (list (car c) (nth 1 c)) c))) + (mapcar #'(lambda (c) (if (consp c) (list (car c) (nth 1 c)) c)) steps) (list* 'while (list 'not (car endtest)) (append body (let ((sets (mapcar - (function - (lambda (c) - (and (consp c) (cdr (cdr c)) - (list (car c) (nth 2 c))))) + #'(lambda (c) + (and (consp c) (cdr (cdr c)) + (list (car c) (nth 2 c)))) steps))) (setq sets (delq nil sets)) (and sets @@ -1264,20 +1259,19 @@ go back to their previous definitions, or lack thereof)." (list* 'letf* (mapcar - (function - (lambda (x) - (if (or (and (fboundp (car x)) - (eq (car-safe (symbol-function (car x))) 'macro)) - (cdr (assq (car x) cl-macro-environment))) - (error "Use `labels', not `flet', to rebind macro names")) - (let ((func (list 'function* - (list 'lambda (cadr x) - (list* 'block (car x) (cddr x)))))) - (if (and (cl-compiling-file) - (boundp 'byte-compile-function-environment)) - (cl-push (cons (car x) (eval func)) - byte-compile-function-environment)) - (list (list 'symbol-function (list 'quote (car x))) func)))) + #'(lambda (x) + (if (or (and (fboundp (car x)) + (eq (car-safe (symbol-function (car x))) 'macro)) + (cdr (assq (car x) cl-macro-environment))) + (error "Use `labels', not `flet', to rebind macro names")) + (let ((func (list 'function* + (list 'lambda (cadr x) + (list* 'block (car x) (cddr x)))))) + (if (and (cl-compiling-file) + (boundp 'byte-compile-function-environment)) + (cl-push (cons (car x) (eval func)) + byte-compile-function-environment)) + (list (list 'symbol-function (list 'quote (car x))) func))) bindings) body)) @@ -1285,7 +1279,7 @@ (defmacro labels (bindings &rest body) "(labels ((FUNC ARGLIST BODY...) ...) FORM...): make temporary func bindings. This is like `flet', except the bindings are lexical instead of dynamic. -Unlike `flet', this macro is fully complaint with the Common Lisp standard." +Unlike `flet', this macro is fully compliant with the Common Lisp standard." (let ((vars nil) (sets nil) (cl-macro-environment cl-macro-environment)) (while bindings (let ((var (gensym))) @@ -1337,39 +1331,36 @@ The main visible difference is that lambdas inside BODY will create lexical closures as in Common Lisp." (let* ((cl-closure-vars cl-closure-vars) - (vars (mapcar (function - (lambda (x) - (or (consp x) (setq x (list x))) - (cl-push (gensym (format "--%s--" (car x))) - cl-closure-vars) - (list (car x) (cadr x) (car cl-closure-vars)))) + (vars (mapcar #'(lambda (x) + (or (consp x) (setq x (list x))) + (cl-push (gensym (format "--%s--" (car x))) + cl-closure-vars) + (list (car x) (cadr x) (car cl-closure-vars))) bindings)) - (ebody + (ebody (cl-macroexpand-all (cons 'progn body) - (nconc (mapcar (function (lambda (x) - (list (symbol-name (car x)) - (list 'symbol-value (caddr x)) - t))) vars) + (nconc (mapcar #'(lambda (x) + (list (symbol-name (car x)) + (list 'symbol-value (caddr x)) + t)) + vars) (list '(defun . cl-defun-expander)) cl-macro-environment)))) (if (not (get (car (last cl-closure-vars)) 'used)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) (cadr x)))) vars) - (sublis (mapcar (function (lambda (x) - (cons (caddr x) - (list 'quote (caddr x))))) + (list 'let (mapcar #'(lambda (x) (list (caddr x) (cadr x))) vars) + (sublis (mapcar #'(lambda (x) + (cons (caddr x) (list 'quote (caddr x)))) vars) ebody)) - (list 'let (mapcar (function (lambda (x) - (list (caddr x) - (list 'make-symbol - (format "--%s--" (car x)))))) + (list 'let (mapcar #'(lambda (x) + (list (caddr x) + (list 'make-symbol + (format "--%s--" (car x))))) vars) (apply 'append '(setf) - (mapcar (function - (lambda (x) - (list (list 'symbol-value (caddr x)) (cadr x)))) + (mapcar #'(lambda (x) + (list (list 'symbol-value (caddr x)) (cadr x))) vars)) ebody)))) @@ -1403,9 +1394,8 @@ a synonym for (list A B C)." (let ((temp (gensym)) (n -1)) (list* 'let* (cons (list temp form) - (mapcar (function - (lambda (v) - (list v (list 'nth (setq n (1+ n)) temp)))) + (mapcar #'(lambda (v) + (list v (list 'nth (setq n (1+ n)) temp))) vars)) body))) @@ -1422,14 +1412,15 @@ (let* ((temp (gensym)) (n 0)) (list 'let (list (list temp form)) (list 'prog1 (list 'setq (cl-pop vars) (list 'car temp)) - (cons 'setq (apply 'nconc - (mapcar (function - (lambda (v) - (list v (list - 'nth - (setq n (1+ n)) - temp)))) - vars))))))))) + (cons 'setq + (apply 'nconc + (mapcar + #'(lambda (v) + (list v (list + 'nth + (setq n (1+ n)) + temp))) + vars))))))))) ;;; Declarations. @@ -1448,7 +1439,7 @@ (if (boundp 'byte-compile-bound-variables) (setq byte-compile-bound-variables ;; todo: this should compute correct binding bits vs. 0 - (append (mapcar #'(lambda (v) (cons v 0)) + (append (mapcar #'(lambda (v) (cons v 0)) (cdr spec)) byte-compile-bound-variables)))) @@ -1604,15 +1595,16 @@ call))))) ;;; Some standard place types from Common Lisp. +(eval-when-compile (defvar ignored-arg)) ; Warning suppression (defsetf aref aset) (defsetf car setcar) (defsetf cdr setcdr) (defsetf elt (seq n) (store) (list 'if (list 'listp seq) (list 'setcar (list 'nthcdr n seq) store) (list 'aset seq n store))) -(defsetf get (x y &optional d) (store) (list 'put x y store)) -(defsetf get* (x y &optional d) (store) (list 'put x y store)) -(defsetf gethash (x h &optional d) (store) (list 'cl-puthash x store h)) +(defsetf get (x y &optional ignored-arg) (store) (list 'put x y store)) +(defsetf get* (x y &optional ignored-arg) (store) (list 'put x y store)) +(defsetf gethash (x h &optional ignored-arg) (store) (list 'cl-puthash x store h)) (defsetf nth (n x) (store) (list 'setcar (list 'nthcdr n x) store)) (defsetf subseq (seq start &optional end) (new) (list 'progn (list 'replace seq new ':start1 start ':end1 end) new)) @@ -1653,7 +1645,7 @@ (defsetf documentation-property put) (defsetf extent-face set-extent-face) (defsetf extent-priority set-extent-priority) -(defsetf extent-property (x y &optional d) (arg) +(defsetf extent-property (x y &optional ignored-arg) (arg) (list 'set-extent-property x y arg)) (defsetf extent-end-position (ext) (store) (list 'progn (list 'set-extent-endpoints (list 'extent-start-position ext) @@ -1673,7 +1665,7 @@ (defsetf frame-visible-p cl-set-frame-visible-p) (defsetf frame-properties (&optional f) (p) `(progn (set-frame-properties ,f ,p) ,p)) -(defsetf frame-property (f p &optional d) (v) +(defsetf frame-property (f p &optional ignored-arg) (v) `(progn (set-frame-property ,f ,v) ,p)) (defsetf frame-width (&optional f) (v) `(progn (set-frame-width ,f ,v) ,v)) @@ -1708,9 +1700,9 @@ ;; Misc (defsetf recent-keys-ring-size set-recent-keys-ring-size) -(defsetf symbol-value-in-buffer (s b &optional u) (store) +(defsetf symbol-value-in-buffer (s b &optional ignored-arg) (store) `(with-current-buffer ,b (set ,s ,store))) -(defsetf symbol-value-in-console (s c &optional u) (store) +(defsetf symbol-value-in-console (s c &optional ignored-arg) (store) `(letf (((selected-console) ,c)) (set ,s ,store))) @@ -1744,7 +1736,7 @@ (defsetf marker-insertion-type set-marker-insertion-type) (defsetf mouse-pixel-position (&optional d) (v) `(progn - set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v)) + (set-mouse-pixel-position ,d ,(car v) ,(car (cdr v)) ,(cdr (cdr v))) ,v)) (defsetf trunc-stack-length set-trunc-stack-length) (defsetf trunc-stack-stack set-trunc-stack-stack) @@ -1791,13 +1783,13 @@ (defsetf window-buffer set-window-buffer t) (defsetf window-display-table set-window-display-table t) (defsetf window-dedicated-p set-window-dedicated-p t) -(defsetf window-height () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-height))) store)) +(defsetf window-height (&optional window) (store) + `(progn (enlarge-window (- ,store (window-height)) nil ,window) ,store)) (defsetf window-hscroll set-window-hscroll) (defsetf window-point set-window-point) (defsetf window-start set-window-start) -(defsetf window-width () (store) - (list 'progn (list 'enlarge-window (list '- store '(window-width)) t) store)) +(defsetf window-width (&optional window) (store) + `(progn (enlarge-window (- ,store (window-width)) t ,window) ,store)) (defsetf x-get-cutbuffer x-store-cutbuffer t) (defsetf x-get-cut-buffer x-store-cut-buffer t) ; groan. (defsetf x-get-secondary-selection x-own-secondary-selection t) @@ -2080,8 +2072,8 @@ the PLACE is not modified before executing BODY." (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) (list* 'let bindings body) - (let ((lets nil) (sets nil) - (unsets nil) (rev (reverse bindings))) + (let ((lets nil) + (rev (reverse bindings))) (while rev (let* ((place (if (symbolp (caar rev)) (list 'symbol-value (list 'quote (caar rev))) @@ -2204,8 +2196,6 @@ (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) - ;; XEmacs change - (include-tag-symbol nil) (side-eff nil) (type nil) (named nil) @@ -2215,7 +2205,7 @@ (cl-push (list 'put (list 'quote name) '(quote structure-documentation) (cl-pop descs)) forms)) (setq descs (cons '(cl-tag-slot) - (mapcar (function (lambda (x) (if (consp x) x (list x)))) + (mapcar #'(lambda (x) (if (consp x) x (list x))) descs))) (while opts (let ((opt (if (consp (car opts)) (caar opts) (car opts))) @@ -2234,13 +2224,9 @@ (if args (setq predicate (car args)))) ((eq opt ':include) (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)) - ;; XEmacs change - include-tag-symbol (intern (format "cl-struct-%s-tags" - include)))) + include-descs (mapcar #'(lambda (x) + (if (consp x) x (list x))) + (cdr args)))) ((eq opt ':print-function) (setq print-func (car args))) ((eq opt ':type) @@ -2370,7 +2356,7 @@ (let* ((name (caar constrs)) (args (cadr (cl-pop constrs))) (anames (cl-arglist-args args)) - (make (mapcar* (function (lambda (s d) (if (memq s anames) s d))) + (make (mapcar* #'(lambda (s d) (if (memq s anames) s d)) slots defaults))) (cl-push (list 'defsubst* name (list* '&cl-defs (list 'quote (cons nil descs)) args) @@ -2394,10 +2380,10 @@ (list 'quote include)) (list 'put (list 'quote name) '(quote cl-struct-print) print-auto) - (mapcar (function (lambda (x) - (list 'put (list 'quote (car x)) - '(quote side-effect-free) - (list 'quote (cdr x))))) + (mapcar #'(lambda (x) + (list 'put (list 'quote (car x)) + '(quote side-effect-free) + (list 'quote (cdr x)))) side-eff)) forms) (cons 'progn (nreverse (cons (list 'quote name) forms))))) @@ -2464,7 +2450,7 @@ (list '<= val (caddr type))))))) ((memq (car-safe type) '(and or not)) (cons (car type) - (mapcar (function (lambda (x) (cl-make-type-test val x))) + (mapcar #'(lambda (x) (cl-make-type-test val x)) (cdr type)))) ((memq (car-safe type) '(member member*)) (list 'and (list 'member* val (list 'quote (cdr type))) t)) @@ -2501,10 +2487,10 @@ (and (or (not (cl-compiling-file)) (< cl-optimize-speed 3) (= cl-optimize-safety 3)) (let ((sargs (and show-args (delq nil (mapcar - (function - (lambda (x) - (and (not (cl-const-expr-p x)) - x))) (cdr form)))))) + #'(lambda (x) + (and (not (cl-const-expr-p x)) + x)) + (cdr form)))))) (list 'progn (list 'or form (if string @@ -2517,8 +2503,13 @@ (defmacro ignore-errors (&rest body) "Execute FORMS; if an error occurs, return nil. Otherwise, return result of last FORM." - (list 'condition-case nil (cons 'progn body) '(error nil))) + `(condition-case nil (progn ,@body) (error nil))) +;;;###autoload +(defmacro ignore-file-errors (&rest body) + "Execute FORMS; if an error of type `file-error' occurs, return nil. +Otherwise, return result of last FORM." + `(condition-case nil (progn ,@body) (file-error nil))) ;;; Some predicates for analyzing Lisp forms. These are used by various ;;; macro expanders to optimize the results in certain common cases. @@ -2672,12 +2663,11 @@ (if (and whole (not (cl-safe-expr-p (cons 'progn argvs)))) whole (if (cl-simple-exprs-p argvs) (setq simple t)) (let ((lets (delq nil - (mapcar* (function - (lambda (argn argv) - (if (or simple (cl-const-expr-p argv)) - (progn (setq body (subst argv argn body)) - (and unsafe (list argn argv))) - (list argn argv)))) + (mapcar* #'(lambda (argn argv) + (if (or simple (cl-const-expr-p argv)) + (progn (setq body (subst argv argn body)) + (and unsafe (list argn argv))) + (list argn argv))) argns argvs)))) (if lets (list 'let lets body) body)))) @@ -2769,45 +2759,49 @@ 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)) + cl-set-elt revappend nreconc + plusp minusp oddp evenp + )) -;;; 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-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. -(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)) +;;; Things that are side-effect-and-error-free. Moved to byte-optimize.el +;(dolist (fun '(eql floatp-safe list* subst acons equalp random-state-p +; copy-tree sublis)) +; (put fun 'side-effect-free 'error-free)) (run-hooks 'cl-macs-load-hook) diff -r 76b7d63099ad -r 8626e4521993 lisp/cl.el --- a/lisp/cl.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/cl.el Mon Aug 13 11:07:10 2007 +0200 @@ -183,7 +183,7 @@ careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." (if (symbolp place) - (list 'car (list 'prog1 place (list 'setq place (list 'cdr place)))) + `(car (prog1 ,place (setq ,place (cdr ,place)))) (cl-do-pop place))) (defmacro push (x place) @@ -191,7 +191,7 @@ Analogous to (setf PLACE (cons X PLACE)), though more careful about evaluating each argument only once and in the right order. PLACE may be a symbol, or any generalized variable allowed by `setf'." - (if (symbolp place) (list 'setq place (list 'cons x place)) + (if (symbolp place) `(setq ,place (cons ,x ,place)) (list 'callf2 'cons x place))) (defmacro pushnew (x place &rest keys) @@ -225,20 +225,9 @@ ;;; Control structures. -;; These macros are so simple and so often-used that it's better to have -;; them all the time than to load them from cl-macs.el. - -;; NOTE: these macros were moved to subr.el in FSF 20. It is of no -;; consequence to XEmacs, because we preload this file, and they -;; should better remain here. - -(defmacro when (cond &rest body) - "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." - (list 'if cond (cons 'progn body))) - -(defmacro unless (cond &rest body) - "(unless COND BODY...): if COND yields nil, do BODY, else return nil." - (cons 'if (cons cond (cons nil body)))) +;; The macros `when' and `unless' are so useful that we want them to +;; ALWAYS be available. So they've been moved from cl.el to eval.c. +;; Note: FSF Emacs moved them to subr.el in FSF 20. (defun cl-map-extents (&rest cl-args) ;; XEmacs: This used to check for overlays first, but that's wrong @@ -406,6 +395,9 @@ ;;; List functions. +;; These functions are made known to the byte-compiler by cl-macs.el +;; and turned into efficient car and cdr bytecodes. + (defalias 'first 'car) (defalias 'rest 'cdr) (defalias 'endp 'null) @@ -558,30 +550,35 @@ "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)) +;;; `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)) -(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))) +;;; `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 nbutlast (x &optional n) +; "Modify LIST to remove the last N elements." +; (let ((m (length x))) +; (or n (setq n 1)) +; (and (< n m) +; (progn +; (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) +; x)))) (defun list* (arg &rest rest) ; See compiler macro in cl-macs.el "Return a new list with specified args as elements, cons'd to last arg. @@ -602,14 +599,16 @@ (push (pop list) res)) (nreverse res))) -(defun copy-list (list) - "Return a copy of a list, which may be a dotted list. -The elements of the list are not copied, just the list structure itself." - (if (consp list) - (let ((res nil)) - (while (consp list) (push (pop list) res)) - (prog1 (nreverse res) (setcdr res list))) - (car list))) +;;; `copy-list' is implemented as a C primitive, as of 1998-11 + +;(defun copy-list (list) +; "Return a copy of a list, which may be a dotted list. +;The elements of the list are not copied, just the list structure itself." +; (if (consp list) +; (let ((res nil)) +; (while (consp list) (push (pop list) res)) +; (prog1 (nreverse res) (setcdr res list))) +; (car list))) (defun cl-maclisp-member (item list) (while (and list (not (equal item (car list)))) (setq list (cdr list))) @@ -681,45 +680,45 @@ ;(load "cl-defs") ;;; Define data for indentation and edebug. -(mapcar (function - (lambda (entry) - (mapcar (function - (lambda (func) - (put func 'lisp-indent-function (nth 1 entry)) - (put func 'lisp-indent-hook (nth 1 entry)) - (or (get func 'edebug-form-spec) - (put func 'edebug-form-spec (nth 2 entry))))) - (car entry)))) - '(((defun* defmacro*) defun) - ((function*) nil - (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) - ((eval-when) 1 (sexp &rest form)) - ((when unless) 1 (&rest form)) - ((declare) nil (&rest sexp)) - ((the) 1 (sexp &rest form)) - ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) - ((block return-from) 1 (sexp &rest form)) - ((return) nil (&optional form)) - ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) - (form &rest form) - &rest form)) - ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) - ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) - ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) - ((psetq setf psetf) nil edebug-setq-form) - ((progv) 2 (&rest form)) - ((flet labels macrolet) 1 - ((&rest (sexp sexp &rest form)) &rest form)) - ((symbol-macrolet lexical-let lexical-let*) 1 - ((&rest &or symbolp (symbolp form)) &rest form)) - ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) - ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) - ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) - ((letf letf*) 1 ((&rest (&rest form)) &rest form)) - ((callf destructuring-bind) 2 (sexp form &rest form)) - ((callf2) 3 (sexp form form &rest form)) - ((loop) defun (&rest &or symbolp form)) - ((ignore-errors) 0 (&rest form)))) +(mapc + #'(lambda (entry) + (mapc + #'(lambda (func) + (put func 'lisp-indent-function (nth 1 entry)) + (put func 'lisp-indent-hook (nth 1 entry)) + (or (get func 'edebug-form-spec) + (put func 'edebug-form-spec (nth 2 entry)))) + (car entry))) + '(((defun* defmacro*) defun) + ((function*) nil + (&or symbolp ([&optional 'macro] 'lambda (&rest sexp) &rest form))) + ((eval-when) 1 (sexp &rest form)) + ((when unless) 1 (&rest form)) + ((declare) nil (&rest sexp)) + ((the) 1 (sexp &rest form)) + ((case ecase typecase etypecase) 1 (form &rest (sexp &rest form))) + ((block return-from) 1 (sexp &rest form)) + ((return) nil (&optional form)) + ((do do*) 2 ((&rest &or symbolp (symbolp &optional form form)) + (form &rest form) + &rest form)) + ((dolist dotimes) 1 ((symbolp form &rest form) &rest form)) + ((do-symbols) 1 ((symbolp form &optional form form) &rest form)) + ((do-all-symbols) 1 ((symbolp form &optional form) &rest form)) + ((psetq setf psetf) nil edebug-setq-form) + ((progv) 2 (&rest form)) + ((flet labels macrolet) 1 + ((&rest (sexp sexp &rest form)) &rest form)) + ((symbol-macrolet lexical-let lexical-let*) 1 + ((&rest &or symbolp (symbolp form)) &rest form)) + ((multiple-value-bind) 2 ((&rest symbolp) &rest form)) + ((multiple-value-setq) 1 ((&rest symbolp) &rest form)) + ((incf decf remf pop push pushnew shiftf rotatef) nil (&rest form)) + ((letf letf*) 1 ((&rest (&rest form)) &rest form)) + ((callf destructuring-bind) 2 (sexp form &rest form)) + ((callf2) 3 (sexp form form &rest form)) + ((loop) defun (&rest &or symbolp form)) + ((ignore-errors) 0 (&rest form)))) ;;; This goes here so that cl-macs can find it if it loads right now. diff -r 76b7d63099ad -r 8626e4521993 lisp/cmdloop.el --- a/lisp/cmdloop.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/cmdloop.el Mon Aug 13 11:07:10 2007 +0200 @@ -433,9 +433,9 @@ (while (stringp ans) (setq ans (downcase (read-string p nil t))) ;no history (cond ((string-equal ans (gettext "yes")) - (setq ans 't)) + (setq ans t)) ((string-equal ans (gettext "no")) - (setq ans 'nil)) + (setq ans nil)) (t (ding nil 'yes-or-no-p) (discard-input) diff -r 76b7d63099ad -r 8626e4521993 lisp/code-files.el --- a/lisp/code-files.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/code-files.el Mon Aug 13 11:07:10 2007 +0200 @@ -57,20 +57,14 @@ 'buffer-file-coding-system-for-read) (defvar file-coding-system-alist - '(("\\.elc$" . (binary . binary)) -;; This must not be neccessary, slb suggests -kkm + `( +;; This must not be necessary, slb suggests -kkm ;; ("loaddefs.el$" . (binary . binary)) - ("\\.tar$" . (binary . binary)) - ("\\.\\(tif\\|tiff\\)$" . (binary . binary)) - ("\\.png$" . (binary . binary)) - ("\\.gif$" . (binary . binary)) - ("\\.\\(jpeg\\|jpg\\)$" . (binary . binary)) - ("TUTORIAL\\.hr$" . iso-8859-2) - ("TUTORIAL\\.pl$" . iso-8859-2) - ("TUTORIAL\\.ro$" . iso-8859-2) + ,@(mapcar + #'(lambda (regexp) (cons regexp 'binary)) binary-file-regexps) + ("TUTORIAL\\.\\(?:hr\\|pl\\|ro\\)\\'" . iso-8859-2) ;; ("\\.\\(el\\|emacs\\|info\\(-[0-9]+\\)?\\|texi\\)$" . iso-2022-8) ;; ("\\(ChangeLog\\|CHANGES-beta\\)$" . iso-2022-8) - ("\\.\\(gz\\|Z\\)$" . binary) ("/spool/mail/.*$" . convert-mbox-coding-system)) "Alist to decide a coding system to use for a file I/O operation. The format is ((PATTERN . VAL) ...), @@ -106,7 +100,7 @@ "Set EOL type of buffer-file-coding-system of the current buffer to something other than what it is at the moment." (interactive) - (let ((eol-type + (let ((eol-type (coding-system-eol-type buffer-file-coding-system))) (setq buffer-file-coding-system (subsidiary-coding-system @@ -153,7 +147,7 @@ (let ((alist file-coding-system-alist) (found nil) (codesys nil)) - (let ((case-fold-search (eq system-type 'vax-vms))) + (let ((case-fold-search nil)) (setq filename (file-name-sans-versions filename)) (while (and (not found) alist) (if (string-match (car (car alist)) filename) @@ -179,7 +173,7 @@ (let ((alist file-coding-system-alist) (found nil) (codesys nil)) - (let ((case-fold-search (eq system-type 'vax-vms))) + (let ((case-fold-search nil)) (setq filename (file-name-sans-versions filename)) (while (and (not found) alist) (if (string-match (car (car alist)) filename) @@ -396,7 +390,7 @@ See also `insert-file-contents-access-hook', `insert-file-contents-pre-hook', `insert-file-contents-error-hook', and `insert-file-contents-post-hook'." - (let (return-val coding-system used-codesys conversion-func) + (let (return-val coding-system used-codesys) ;; OK, first load the file. (condition-case err (progn diff -r 76b7d63099ad -r 8626e4521993 lisp/code-process.el --- a/lisp/code-process.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/code-process.el Mon Aug 13 11:07:10 2007 +0200 @@ -30,6 +30,10 @@ ;;; Code: +(eval-when-compile + (defvar buffer-file-type) + (defvar binary-process-output)) + (defvar process-coding-system-alist nil "Alist to decide a coding system to use for a process I/O operation. The format is ((PATTERN . VAL) ...), @@ -66,7 +70,7 @@ (let (ret) (catch 'found (let ((alist process-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search nil)) (while alist (if (string-match (car (car alist)) program) (throw 'found (setq ret (cdr (car alist)))) @@ -106,25 +110,16 @@ and returns a numeric exit status or a signal description string. If you quit, the process is first killed with SIGINT, then with SIGKILL if you quit again before the process exits." - (let ((temp (cond ((eq system-type 'vax-vms) - (make-temp-name "tmp:emacs")) - ((or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "em"))) - (t - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "emacs")))))) + (let ((temp + (make-temp-name + (concat (file-name-as-directory (temp-directory)) + (if (memq system-type '(ms-dos windows-nt)) "em" "emacs"))))) (unwind-protect (let (cs-r cs-w) (let (ret) (catch 'found (let ((alist process-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search nil)) (while alist (if (string-match (car (car alist)) program) (throw 'found (setq ret (cdr (car alist))))) @@ -142,16 +137,13 @@ (or coding-system-for-read cs-r)) (coding-system-for-write (or coding-system-for-write cs-w))) - (if (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (if (memq system-type '(ms-dos windows-nt)) (let ((buffer-file-type binary-process-output)) (write-region start end temp nil 'silent)) (write-region start end temp nil 'silent)) (if deletep (delete-region start end)) (apply #'call-process program temp buffer displayp args))) - (condition-case () - (delete-file temp) - (file-error nil))))) + (ignore-file-errors (delete-file temp))))) (defun start-process (name buffer program &rest program-args) "Start a program in a subprocess. Return the process object for it. @@ -170,7 +162,7 @@ (let (ret) (catch 'found (let ((alist process-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms))) + (case-fold-search nil)) (while alist (if (string-match (car (car alist)) program) (throw 'found (setq ret (cdr (car alist))))) @@ -224,7 +216,7 @@ (let (ret) (catch 'found (let ((alist network-coding-system-alist) - (case-fold-search (eq system-type 'vax-vms)) + (case-fold-search nil) pattern) (while alist (setq pattern (car (car alist))) diff -r 76b7d63099ad -r 8626e4521993 lisp/config.el --- a/lisp/config.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/config.el Mon Aug 13 11:07:10 2007 +0200 @@ -33,13 +33,13 @@ "File containing configuration parameters and their values.") (defvar config-value-hash-table nil - "Hashtable to store configuration parameters and their values.") + "Hash table to store configuration parameters and their values.") ;;;###autoload (defun config-value-hash-table () - "Return hashtable of configuration parameters and their values." + "Return hash table of configuration parameters and their values." (when (null config-value-hash-table) - (setq config-value-hash-table (make-hashtable 300)) + (setq config-value-hash-table (make-hash-table :size 300)) (save-excursion (let ((buf (get-buffer-create " *Config*"))) (set-buffer buf) diff -r 76b7d63099ad -r 8626e4521993 lisp/cus-edit.el --- a/lisp/cus-edit.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/cus-edit.el Mon Aug 13 11:07:10 2007 +0200 @@ -39,7 +39,7 @@ ;; very slow in an average XEmacs because of the large number of ;; symbols requiring a large number of funcalls -- XEmacs with Gnus ;; can grow to some 17000 symbols without ever doing anything fancy. -;; It would probably pay off to make a hashtable of symbols known to +;; It would probably pay off to make a hash table of symbols known to ;; Custom, similar to custom-group-hash-table. ;; This is not top priority, because none of the functions that do @@ -282,7 +282,7 @@ (defun custom-split-regexp-maybe (regexp) "If REGEXP is a string, split it to a list at `\\|'. You can get the original back with from the result with: - (mapconcat 'identity result \"\\|\") + (mapconcat #'identity result \"\\|\") IF REGEXP is not a string, return it unchanged." (if (stringp regexp) diff -r 76b7d63099ad -r 8626e4521993 lisp/custom.el --- a/lisp/custom.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/custom.el Mon Aug 13 11:07:10 2007 +0200 @@ -284,8 +284,7 @@ information." `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) -;; This is preloaded very early, so we avoid using CL features. -(defvar custom-group-hash-table (make-hashtable 300 'eq) +(defvar custom-group-hash-table (make-hash-table :size 300 :test 'eq) "Hash-table of non-empty groups.") (defun custom-add-to-group (group option widget) diff -r 76b7d63099ad -r 8626e4521993 lisp/derived.el --- a/lisp/derived.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/derived.el Mon Aug 13 11:07:10 2007 +0200 @@ -146,35 +146,35 @@ (setq docstring nil))) (setq docstring (or docstring (derived-mode-make-docstring parent child))) - (` (progn - (derived-mode-init-mode-variables (quote (, child))) - (defun (, child) () - (, docstring) + `(progn + (derived-mode-init-mode-variables (quote ,child)) + (defun ,child () + ,docstring (interactive) ; Run the parent. - ((, parent)) + (,parent) ; Identify special modes. - (if (get (quote (, parent)) 'special) - (put (quote (, child)) 'special t)) + (if (get (quote ,parent) 'special) + (put (quote ,child) 'special t)) ;; XEmacs addition - (let ((mode-class (get (quote (, parent)) 'mode-class))) + (let ((mode-class (get (quote ,parent) 'mode-class))) (if mode-class - (put (quote (, child)) 'mode-class mode-class))) + (put (quote ,child) 'mode-class mode-class))) ; Identify the child mode. - (setq major-mode (quote (, child))) - (setq mode-name (, name)) + (setq major-mode (quote ,child)) + (setq mode-name ,name) ; Set up maps and tables. - (derived-mode-set-keymap (quote (, child))) - (derived-mode-set-syntax-table (quote (, child))) - (derived-mode-set-abbrev-table (quote (, child))) + (derived-mode-set-keymap (quote ,child)) + (derived-mode-set-syntax-table (quote ,child)) + (derived-mode-set-abbrev-table (quote ,child)) ; Splice in the body (if any). - (,@ body) + ,@body ;;; ; Run the setup function, if ;;; ; any -- this will soon be ;;; ; obsolete. -;;; (derived-mode-run-setup-function (quote (, child))) +;;; (derived-mode-run-setup-function (quote ,child)) ; Run the hooks, if any. - (derived-mode-run-hooks (quote (, child))))))) + (derived-mode-run-hooks (quote ,child))))) ;; PUBLIC: find the ultimate class of a derived mode. @@ -223,30 +223,30 @@ (if (boundp (derived-mode-map-name mode)) t - (eval (` (defvar (, (derived-mode-map-name mode)) - ;; XEmacs change - (make-sparse-keymap (derived-mode-map-name mode)) - (, (format "Keymap for %s." mode))))) + (eval `(defvar ,(derived-mode-map-name mode) + ;; XEmacs change + (make-sparse-keymap (derived-mode-map-name mode)) + ,(format "Keymap for %s." mode))) (put (derived-mode-map-name mode) 'derived-mode-unmerged t)) (if (boundp (derived-mode-syntax-table-name mode)) t - (eval (` (defvar (, (derived-mode-syntax-table-name mode)) - ;; XEmacs change - ;; Make a syntax table which doesn't specify anything - ;; for any char. Valid data will be merged in by - ;; derived-mode-merge-syntax-tables. - ;; (make-char-table 'syntax-table nil) - (make-syntax-table) - (, (format "Syntax table for %s." mode))))) + (eval `(defvar ,(derived-mode-syntax-table-name mode) + ;; XEmacs change + ;; Make a syntax table which doesn't specify anything + ;; for any char. Valid data will be merged in by + ;; derived-mode-merge-syntax-tables. + ;; (make-char-table 'syntax-table nil) + (make-syntax-table) + ,(format "Syntax table for %s." mode))) (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t)) (if (boundp (derived-mode-abbrev-table-name mode)) t - (eval (` (defvar (, (derived-mode-abbrev-table-name mode)) - (progn (define-abbrev-table (derived-mode-abbrev-table-name mode) nil) - (make-abbrev-table)) - (, (format "Abbrev table for %s." mode))))))) + (eval `(defvar ,(derived-mode-abbrev-table-name mode) + (progn (define-abbrev-table (derived-mode-abbrev-table-name mode) nil) + (make-abbrev-table)) + ,(format "Abbrev table for %s." mode))))) (defun derived-mode-make-docstring (parent child) "Construct a docstring for a new mode if none is provided." diff -r 76b7d63099ad -r 8626e4521993 lisp/disass.el --- a/lisp/disass.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/disass.el Mon Aug 13 11:07:10 2007 +0200 @@ -39,18 +39,12 @@ ;;; Code: -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-opt.el. -;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. -;;; The variable byte-code-vector is defined by the new bytecomp.el. -;;; The function byte-decompile-lapcode is defined in byte-optimize.el. (require 'byte-optimize) (defvar disassemble-column-1-indent 8 "*") (defvar disassemble-column-2-indent 10 "*") (defvar disassemble-recursive-indent 3 "*") - ;;;###autoload (defun disassemble (object &optional buffer indent interactive-p) "Print disassembled code for OBJECT in (optional) BUFFER. @@ -75,8 +69,8 @@ (defun disassemble-internal (obj indent interactive-p) - (let ((macro 'nil) - (name 'nil) + (let ((macro nil) + (name nil) args) (while (symbolp obj) (setq name obj @@ -169,8 +163,8 @@ (defun disassemble-1 (obj indent) - "Prints the byte-code call OBJ in the current buffer. -OBJ should be a call to BYTE-CODE generated by the byte compiler." + "Print the byte-code call OBJ in the current buffer. +OBJ should be a compiled-function object generated by the byte compiler." (let (bytes constvec) (if (consp obj) (setq bytes (car (cdr obj)) ; the byte code @@ -254,10 +248,10 @@ ((eq (car-safe (car-safe arg)) 'byte-code) (insert "(...)\n") (mapcar ;recurse on list of byte-code objects - '(lambda (obj) - (disassemble-1 - obj - (+ indent disassemble-recursive-indent))) + #'(lambda (obj) + (disassemble-1 + obj + (+ indent disassemble-recursive-indent))) arg)) (t ;; really just a constant diff -r 76b7d63099ad -r 8626e4521993 lisp/dragdrop.el --- a/lisp/dragdrop.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/dragdrop.el Mon Aug 13 11:07:10 2007 +0200 @@ -51,7 +51,7 @@ (defcustom dragdrop-autoload-tm-view nil "*{EXPERIMENTAL} If non-nil, autoload tm-view to decode MIME data. -Otherwise, the buffer is only decoded if tm-view is already avaiable." +Otherwise, the buffer is only decoded if tm-view is already available." :type 'boolean :group 'drag-n-drop) @@ -176,7 +176,7 @@ (and (or (eq (cadr flist) t) (= (cadr flist) button)) (or (eq (caddr flist) t) - (dragdrop-compare-mods (caddr flist) modifiers)) + (dragdrop-compare-mods (caddr flist) mods)) (apply (car flist) `(,event ,object ,@(cdddr flist))) ;; (funcall (car flist) event object) (throw 'dragdrop-drop-is-done t)) @@ -356,7 +356,7 @@ This function uses special data types if the low-level protocol requires it. It does so by calling dragdrop-drag-pure-text." - (dragdrop-drag-pure-text event + (experimental-dragdrop-drag-pure-text event (buffer-substring-no-properties begin end))) (defun experimental-dragdrop-drag-pure-text (event text) diff -r 76b7d63099ad -r 8626e4521993 lisp/easymenu.el --- a/lisp/easymenu.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/easymenu.el Mon Aug 13 11:07:10 2007 +0200 @@ -148,9 +148,9 @@ The first element should be the submenu name. That's used as the menu item in the top-level menu. The cdr of the submenu list is a list of menu items, as above." - (` (progn - (defvar (, symbol) nil (, doc)) - (easy-menu-do-define (quote (, symbol)) (, maps) (, doc) (, menu))))) + `(progn + (defvar ,symbol nil ,doc) + (easy-menu-do-define (quote ,symbol) ,maps ,doc ,menu))) (defun easy-menu-do-define (symbol maps doc menu) (if (featurep 'menubar) diff -r 76b7d63099ad -r 8626e4521993 lisp/etags.el --- a/lisp/etags.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/etags.el Mon Aug 13 11:07:10 2007 +0200 @@ -1064,7 +1064,7 @@ ;; Sample uses of find-tag-hook and find-tag-default-hook -;; This is wrong. We should either make this behaviour default and +;; This is wrong. We should either make this behavior default and ;; back it up, or not use it at all. For now, I've commented it out. ;; --hniksic diff -r 76b7d63099ad -r 8626e4521993 lisp/files.el --- a/lisp/files.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/files.el Mon Aug 13 11:07:10 2007 +0200 @@ -76,8 +76,7 @@ (regexp :tag "To"))) :group 'find-file) -;;; Turn off backup files on VMS since it has version numbers. -(defcustom make-backup-files (not (eq system-type 'vax-vms)) +(defcustom make-backup-files t "*Non-nil means make a backup of a file the first time it is saved. This can be done by renaming the file or by copying. @@ -414,8 +413,7 @@ "Change current directory to given absolute file name DIR." ;; Put the name into directory syntax now, ;; because otherwise expand-file-name may give some bad results. - (if (not (eq system-type 'vax-vms)) - (setq dir (file-name-as-directory dir))) + (setq dir (file-name-as-directory dir)) ;; XEmacs change: stig@hackvan.com (if find-file-use-truenames (setq dir (file-truename dir))) @@ -813,8 +811,7 @@ ;; If the home dir is just /, don't change it. (not (and (= (match-end 0) 1) ;#### unix-specific (= (aref filename 0) ?/))) - (not (and (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (not (and (memq system-type '(ms-dos windows-nt)) (save-match-data (string-match "^[a-zA-Z]:/$" filename))))) (setq filename @@ -825,11 +822,7 @@ filename))) (defcustom find-file-not-true-dirname-list nil - "*List of logical names for which visiting shouldn't save the true dirname. -On VMS, when you visit a file using a logical name that searches a path, -you may or may not want the visited file name to record the specific -directory where the file was found. If you *do not* want that, add the logical -name to this list as a string." + "*List of logical names for which visiting shouldn't save the true dirname." :type '(repeat (string :tag "Name")) :group 'find-file) @@ -1004,15 +997,6 @@ (unless buffer-file-truename (setq buffer-file-truename truename)) (setq buffer-file-number number) - ;; On VMS, we may want to remember which directory in - ;; a search list the file was found in. - (and (eq system-type 'vax-vms) - (let (logical) - (if (string-match ":" (file-name-directory filename)) - (setq logical (substring (file-name-directory filename) - 0 (match-beginning 0)))) - (not (member logical find-file-not-true-dirname-list))) - (setq buffer-file-name buffer-file-truename)) (and find-file-use-truenames ;; This should be in C. Put pathname ;; abbreviations that have been explicitly @@ -1149,49 +1133,48 @@ '(("\\.te?xt\\'" . text-mode) ("\\.[ch]\\'" . c-mode) ("\\.el\\'" . emacs-lisp-mode) - ("\\.\\([CH]\\|cc\\|hh\\)\\'" . c++-mode) + ("\\.\\(?:[CH]\\|cc\\|hh\\)\\'" . c++-mode) ("\\.[ch]\\(pp\\|xx\\|\\+\\+\\)\\'" . c++-mode) ("\\.java\\'" . java-mode) ("\\.idl\\'" . idl-mode) - ("\\.f\\(or\\)?\\'" . fortran-mode) - ("\\.F\\(OR\\)?\\'" . fortran-mode) + ("\\.f\\(?:or\\)?\\'" . fortran-mode) + ("\\.F\\(?:OR\\)?\\'" . fortran-mode) ("\\.[fF]90\\'" . f90-mode) ;;; Less common extensions come here ;;; so more common ones above are found faster. ("\\.\\([pP][Llm]\\|al\\)\\'" . perl-mode) ("\\.py\\'" . python-mode) - ("\\.texi\\(nfo\\)?\\'" . texinfo-mode) + ("\\.texi\\(?:nfo\\)?\\'" . texinfo-mode) ("\\.ad[abs]\\'" . ada-mode) - ("\\.c?l\\(i?sp\\)?\\'" . lisp-mode) - ("\\.p\\(as\\)?\\'" . pascal-mode) + ("\\.c?l\\(?:i?sp\\)?\\'" . lisp-mode) + ("\\.p\\(?:as\\)?\\'" . pascal-mode) ("\\.ltx\\'" . latex-mode) ("\\.[sS]\\'" . asm-mode) - ("[Cc]hange.?[Ll]og?\\(.[0-9]+\\)?\\'" . change-log-mode) + ("[Cc]hange.?[Ll]og?\\(?:.[0-9]+\\)?\\'" . change-log-mode) ("\\$CHANGE_LOG\\$\\.TXT" . change-log-mode) ("\\.scm?\\(?:\\.[0-9]*\\)?\\'" . scheme-mode) ("\\.e\\'" . eiffel-mode) ("\\.mss\\'" . scribe-mode) - ("\\.m\\([mes]\\|an\\)\\'" . nroff-mode) + ("\\.m\\(?:[mes]\\|an\\)\\'" . nroff-mode) ("\\.icn\\'" . icon-mode) - ("\\.\\([ckz]?sh\\|shar\\)\\'" . sh-mode) + ("\\.\\(?:[ckz]?sh\\|shar\\)\\'" . sh-mode) ;; #### Unix-specific! - ("/\\.\\(bash_\\|z\\)?\\(profile\\|login\||logout\\)\\'" . sh-mode) - ("/\\.\\([ckz]sh\\|bash\\|tcsh\\|es\\|xinit\\|startx\\)rc\\'" . sh-mode) - ("/\\.\\([kz]shenv\\|xsession\\)\\'" . sh-mode) + ("/\\.\\(?:bash_\\|z\\)?\\(profile\\|login\||logout\\)\\'" . sh-mode) + ("/\\.\\(?:[ckz]sh\\|bash\\|tcsh\\|es\\|xinit\\|startx\\)rc\\'" . sh-mode) + ("/\\.\\(?:[kz]shenv\\|xsession\\)\\'" . sh-mode) ;; The following come after the ChangeLog pattern for the sake of ;; ChangeLog.1, etc. and after the .scm.[0-9] pattern too. ("\\.[12345678]\\'" . nroff-mode) ("\\.[tT]e[xX]\\'" . tex-mode) - ("\\.\\(sty\\|cls\\|bbl\\)\\'" . latex-mode) + ("\\.\\(?:sty\\|cls\\|bbl\\)\\'" . latex-mode) ("\\.bib\\'" . bibtex-mode) ("\\.article\\'" . text-mode) ("\\.letter\\'" . text-mode) - ("\\.\\(tcl\\|exp\\)\\'" . tcl-mode) + ("\\.\\(?:tcl\\|exp\\)\\'" . tcl-mode) ("\\.wrl\\'" . vrml-mode) ("\\.awk\\'" . awk-mode) ("\\.prolog\\'" . prolog-mode) - ("\\.tar\\'" . tar-mode) - ("\\.\\(arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) + ("\\.\\(?:arc\\|zip\\|lzh\\|zoo\\)\\'" . archive-mode) ;; Mailer puts message to be edited in /tmp/Re.... or Message ;; #### Unix-specific! ("\\`/tmp/Re" . text-mode) @@ -1205,7 +1188,7 @@ ("\\.oak\\'" . scheme-mode) ("\\.s?html?\\'" . html-mode) ("\\.htm?l?3\\'" . html3-mode) - ("\\.\\(sgml?\\|dtd\\)\\'" . sgml-mode) + ("\\.\\(?:sgml?\\|dtd\\)\\'" . sgml-mode) ("\\.c?ps\\'" . postscript-mode) ;; .emacs following a directory delimiter in either Unix or ;; Windows syntax. @@ -1218,11 +1201,8 @@ ("\\.X\\(defaults\\|environment\\|resources\\|modmap\\)\\'" . xrdb-mode) ;; #### The following three are Unix-specific (but do we care?) ("/app-defaults/" . xrdb-mode) - ("\\.[^/]*wm\\'" . winmgr-mode) - ("\\.[^/]*wm2?rc" . winmgr-mode) - ("\\.[Jj][Pp][Ee]?[Gg]\\'" . image-mode) - ("\\.[Pp][Nn][Gg]\\'" . image-mode) - ("\\.[Gg][Ii][Ff]\\'" . image-mode) + ("\\.[^/]*wm2?\\(?:rc\\)?\\'" . winmgr-mode) + ("\\.\\(?:jpe?g\\|JPE?G\\|png\\|PNG\\|gif\\|GIF\\|tiff?\\|TIFF?\\)\\'" . image-mode) ) "Alist of filename patterns vs. corresponding major mode functions. Each element looks like (REGEXP . FUNCTION) or (REGEXP FUNCTION NON-NIL). @@ -1258,8 +1238,31 @@ with the name of the interpreter specified in the first line. If it matches, mode MODE is selected.") -(defvar inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'" "\\.tgz\\'" - "\\.tar\\.gz\\'")) +(defvar binary-file-regexps + (purecopy + '("\\.\\(?:bz2\\|elc\\|g\\(if\\|z\\)\\|jp\\(eg\\|g\\)\\|png\\|t\\(ar\\|gz\\|iff\\)\\|[Zo]\\)\\'")) + "List of regexps of filenames containing binary (non-text) data.") + +; (eval-when-compile +; (require 'regexp-opt) +; (list +; (format "\\.\\(?:%s\\)\\'" +; (regexp-opt +; '("tar" +; "tgz" +; "gz" +; "bz2" +; "Z" +; "o" +; "elc" +; "png" +; "gif" +; "tiff" +; "jpg" +; "jpeg")))))) + +(defvar inhibit-first-line-modes-regexps + (purecopy binary-file-regexps) "List of regexps; if one matches a file name, don't look for `-*-'.") (defvar inhibit-first-line-modes-suffixes nil @@ -1309,7 +1312,7 @@ (mode nil)) ;; Find first matching alist entry. (let ((case-fold-search - (memq system-type '(vax-vms windows-nt)))) + (memq system-type '(windows-nt)))) (while (and (not mode) alist) (if (string-match (car (car alist)) name) (if (and (consp (cdr (car alist))) @@ -1722,8 +1725,6 @@ (let ((new-name (file-name-nondirectory buffer-file-name))) (if (string= new-name "") (error "Empty file name")) - (if (eq system-type 'vax-vms) - (setq new-name (downcase new-name))) (setq default-directory (file-name-directory buffer-file-name)) (or (string= new-name (buffer-name)) (rename-buffer new-name t)))) @@ -1917,9 +1918,7 @@ ;; Now delete the old versions, if desired. (if delete-old-versions (while targets - (condition-case () - (delete-file (car targets)) - (file-error nil)) + (ignore-file-errors (delete-file (car targets))) (setq targets (cdr targets)))) setmodes) (file-error nil))))))))) @@ -1934,28 +1933,17 @@ (if handler (funcall handler 'file-name-sans-versions name keep-backup-version) (substring name 0 - (if (eq system-type 'vax-vms) - ;; VMS version number is (a) semicolon, optional - ;; sign, zero or more digits or (b) period, option - ;; sign, zero or more digits, provided this is the - ;; second period encountered outside of the - ;; device/directory part of the file name. - (or (string-match ";[-+]?[0-9]*\\'" name) - (if (string-match "\\.[^]>:]*\\(\\.[-+]?[0-9]*\\)\\'" - name) - (match-beginning 1)) - (length name)) - (if keep-backup-version - (length name) - (or (string-match "\\.~[0-9.]+~\\'" name) - ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~" - (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name))) - (and pos - ;; #### - is this filesystem check too paranoid? - (file-exists-p (substring name 0 pos)) - pos)) - (string-match "~\\'" name) - (length name)))))))) + (if keep-backup-version + (length name) + (or (string-match "\\.~[0-9.]+~\\'" name) + ;; XEmacs - VC uses extensions like ".~tagname~" or ".~1.1.5.2~" + (let ((pos (string-match "\\.~\\([^.~ \t]+\\|[0-9.]+\\)~\\'" name))) + (and pos + ;; #### - is this filesystem check too paranoid? + (file-exists-p (substring name 0 pos)) + pos)) + (string-match "~\\'" name) + (length name))))))) (defun file-ownership-preserved-p (file) "Return t if deleting FILE and rewriting it would preserve the owner." @@ -2030,8 +2018,6 @@ (string-to-int (substring fn bv-length -1)) 0)) -;; I believe there is no need to alter this behavior for VMS; -;; since backup files are not made on VMS, it should not get called. (defun find-backup-file-name (fn) "Find a file name for a backup file, and suggestions for deletions. Value is a list whose car is the name for the backup file @@ -2096,8 +2082,7 @@ (expand-file-name (or directory default-directory)))) ;; On Microsoft OSes, if FILENAME and DIRECTORY have different ;; drive names, they can't be relative, so return the absolute name. - (if (and (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (if (and (memq system-type '(ms-dos windows-nt)) (not (string-equal (substring fname 0 2) (substring directory 0 2)))) filename @@ -2167,9 +2152,7 @@ (not (string= buffer-file-name buffer-auto-save-file-name)) (or force (recent-auto-save-p)) (progn - (condition-case () - (delete-file buffer-auto-save-file-name) - (file-error nil)) + (ignore-file-errors (delete-file buffer-auto-save-file-name)) (set-buffer-auto-saved)))) ;; XEmacs change (from Sun) @@ -2211,19 +2194,6 @@ (set-buffer (buffer-base-buffer))) (if (buffer-modified-p) (let ((recent-save (recent-auto-save-p))) - ;; On VMS, rename file and buffer to get rid of version number. - (if (and (eq system-type 'vax-vms) - (not (string= buffer-file-name - (file-name-sans-versions buffer-file-name)))) - (let (buffer-new-name) - ;; Strip VMS version number before save. - (setq buffer-file-name - (file-name-sans-versions buffer-file-name)) - ;; Construct a (unique) buffer name to correspond. - (let ((buf (create-file-buffer (downcase buffer-file-name)))) - (setq buffer-new-name (buffer-name buf)) - (kill-buffer buf)) - (rename-buffer buffer-new-name))) ;; If buffer has no file name, ask user for one. (or buffer-file-name (let ((filename @@ -2782,12 +2752,11 @@ (not (file-exists-p file-name))) (error "Auto-save file %s not current" file-name)) ((save-window-excursion - (if (not (eq system-type 'vax-vms)) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (call-process "ls" nil standard-output nil - (if (file-symlink-p file) "-lL" "-l") - file file-name))) + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (call-process "ls" nil standard-output nil + (if (file-symlink-p file) "-lL" "-l") + file file-name)) (yes-or-no-p (format "Recover auto save file %s? " file-name))) (switch-to-buffer (find-file-noselect file t)) (let ((buffer-read-only nil)) @@ -3087,16 +3056,12 @@ ;; not its part. Make the regexp say so. (concat "\\`" result "\\'"))) -(defcustom list-directory-brief-switches - (if (eq system-type 'vax-vms) "" "-CF") +(defcustom list-directory-brief-switches "-CF" "*Switches for list-directory to pass to `ls' for brief listing." :type 'string :group 'dired) -(defcustom list-directory-verbose-switches - (if (eq system-type 'vax-vms) - "/PROTECTION/SIZE/DATE/OWNER/WIDTH=(OWNER:10)" - "-l") +(defcustom list-directory-verbose-switches "-l" "*Switches for list-directory to pass to `ls' for verbose listing," :type 'string :group 'dired) @@ -3166,8 +3131,6 @@ (funcall handler 'insert-directory file switches wildcard full-directory-p) (cond - ((eq system-type 'vax-vms) - (vms-read-directory file switches (current-buffer))) ((and (fboundp 'mswindows-insert-directory) (eq system-type 'windows-nt)) (mswindows-insert-directory file switches wildcard full-directory-p)) diff -r 76b7d63099ad -r 8626e4521993 lisp/fill.el --- a/lisp/fill.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/fill.el Mon Aug 13 11:07:10 2007 +0200 @@ -384,6 +384,7 @@ ;;; 97/3/14 jhod: Kinsoku change ;; Spacing is not necessary for charcters of no word-separater. ;; The regexp word-across-newline is used for this check. + (defvar word-across-newline) (if (not (and (featurep 'mule) (stringp word-across-newline))) (subst-char-in-region from (point-max) ?\n ?\ ) @@ -782,7 +783,7 @@ ;; 97/3/14 jhod: This functions are added for Kinsoku support (defun find-space-insertable-point () - "Search backward for a permissable point for inserting justification spaces" + "Search backward for a permissible point for inserting justification spaces" (if (boundp 'space-insertable) (if (re-search-backward space-insertable nil t) (progn (forward-char 1) diff -r 76b7d63099ad -r 8626e4521993 lisp/find-paths.el --- a/lisp/find-paths.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/find-paths.el Mon Aug 13 11:07:10 2007 +0200 @@ -66,9 +66,8 @@ (let ((raw-entries (if (equal 0 max-depth) '() - (directory-files directory nil "^[^.-]"))) + (directory-files directory nil "^[^.-]"))) (reverse-dirs '())) - (while raw-entries (if (null (string-match exclude-regexp (car raw-entries))) (setq reverse-dirs @@ -106,7 +105,7 @@ "lib" emacs-program-name))) ;; in-place or windows-nt - (and + (and (paths-file-readable-directory-p (paths-construct-path (list directory "lisp"))) (paths-file-readable-directory-p (paths-construct-path (list directory "etc")))))) @@ -153,7 +152,7 @@ (defun paths-construct-emacs-directory (root suffix base) "Construct a directory name within the XEmacs hierarchy." (file-name-as-directory - (expand-file-name + (expand-file-name (concat (file-name-as-directory root) suffix @@ -236,7 +235,7 @@ (let ((reverse-directories '())) (while directories (if (paths-file-readable-directory-p (car directories)) - (setq reverse-directories + (setq reverse-directories (cons (car directories) reverse-directories))) (setq directories (cdr directories))) diff -r 76b7d63099ad -r 8626e4521993 lisp/finder.el --- a/lisp/finder.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/finder.el Mon Aug 13 11:07:10 2007 +0200 @@ -162,47 +162,44 @@ (insert ";;; Commentary:\n") (insert ";; Don't edit this file. It's generated by finder.el\n\n") (insert ";;; Code:\n") - (insert "\n(setq finder-package-info '(\n") + (insert "\n(defconst finder-package-info '(\n") (mapcar - (function - (lambda (d) - (mapcar - (function - (lambda (f) - (if (not (member f processed)) - (let (summary keystart keywords) - (setq processed (cons f processed)) - (if (not finder-compile-keywords-quiet) - (message "Processing %s ..." f)) - (save-excursion - (set-buffer (get-buffer-create "*finder-scratch*")) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (insert-file-contents (expand-file-name f d)) - (condition-case err - (setq summary (lm-synopsis) - keywords (lm-keywords)) - (t (message "finder: error processing %s %S" f err)))) - (if (not summary) - nil - (insert (format " (\"%s\"\n " f)) - (prin1 summary (current-buffer)) - (insert "\n ") - (setq keystart (point)) - (insert (if keywords (format "(%s)" keywords) "nil")) - (subst-char-in-region keystart (point) ?, ? ) - (insert "\n ") - (prin1 (abbreviate-file-name d) (current-buffer)) - (insert ")\n")))))) - ;; - ;; Skip null, non-existent or relative pathnames, e.g. "./", if - ;; using load-path, so that they do not interfere with a scan of - ;; library directories only. - (if (and using-load-path - (not (and d (file-name-absolute-p d) (file-exists-p d)))) - nil - (setq d (file-name-as-directory (or d "."))) - (directory-files d nil "^[^=].*\\.el$"))))) + (lambda (d) + (mapcar + (lambda (f) + (when (not (member f processed)) + (let (summary keystart keywords) + (setq processed (cons f processed)) + (if (not finder-compile-keywords-quiet) + (message "Processing %s ..." f)) + (save-excursion + (set-buffer (get-buffer-create "*finder-scratch*")) + (buffer-disable-undo (current-buffer)) + (erase-buffer) + (insert-file-contents (expand-file-name f d)) + (condition-case err + (setq summary (lm-synopsis) + keywords (lm-keywords)) + (t (message "finder: error processing %s %S" f err)))) + (when summary + (insert (format " (\"%s\"\n " f)) + (prin1 summary (current-buffer)) + (insert "\n ") + (setq keystart (point)) + (insert (if keywords (format "(%s)" keywords) "nil")) + (subst-char-in-region keystart (point) ?, ? ) + (insert "\n ") + (prin1 (abbreviate-file-name d) (current-buffer)) + (insert ")\n"))))) + ;; + ;; Skip null, non-existent or relative pathnames, e.g. "./", if + ;; using load-path, so that they do not interfere with a scan of + ;; library directories only. + (if (and using-load-path + (not (and d (file-name-absolute-p d) (file-exists-p d)))) + nil + (setq d (file-name-as-directory (or d "."))) + (directory-files d nil "^[^=].*\\.el$")))) dirs) (insert "))\n\n(provide 'finder-inf)\n\n;;; finder-inf.el ends here\n") (kill-buffer "*finder-scratch*") diff -r 76b7d63099ad -r 8626e4521993 lisp/font-lock.el --- a/lisp/font-lock.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/font-lock.el Mon Aug 13 11:07:10 2007 +0200 @@ -128,8 +128,8 @@ ;; - Keep the faces distinct from each other as far as possible. ;; i.e., (a) above. ;; - Make the face attributes fit the concept as far as possible. -;; i.e., function names might be a bold colour such as blue, comments might -;; be a bright colour such as red, character strings might be brown, because, +;; i.e., function names might be a bold color such as blue, comments might +;; be a bright color such as red, character strings might be brown, because, ;; err, strings are brown (that was not the reason, please believe me). ;; - Don't use a non-nil OVERRIDE unless you have a good reason. ;; Only use OVERRIDE for special things that are easy to define, such as the @@ -375,7 +375,7 @@ Where MATCHER is as for MATCH-HIGHLIGHT with one exception; see below. PRE-MATCH-FORM and POST-MATCH-FORM are evaluated before the first, and after the last, instance MATCH-ANCHORED's MATCHER is used. Therefore they can be -used to initialise before, and cleanup after, MATCHER is used. Typically, +used to initialize before, and cleanup after, MATCHER is used. Typically, PRE-MATCH-FORM is used to move to some position relative to the original MATCHER, before starting with MATCH-ANCHORED's MATCHER. POST-MATCH-FORM might be used to move, before resuming with MATCH-ANCHORED's parent's MATCHER. @@ -533,8 +533,7 @@ :type 'boolean :initialize 'custom-initialize-default :require 'font-lock - :set '(lambda (var val) - (font-lock-mode (or val 0))) + :set #'(lambda (var val) (font-lock-mode (or val 0))) ) (defvar font-lock-fontified nil) ; whether we have hacked this buffer diff -r 76b7d63099ad -r 8626e4521993 lisp/font.el --- a/lisp/font.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/font.el Mon Aug 13 11:07:10 2007 +0200 @@ -32,6 +32,7 @@ (require 'cl) (eval-and-compile + (defvar device-fonts-cache) (condition-case () (require 'custom) (error nil)) @@ -40,8 +41,8 @@ ;; We have the old custom-library, hack around it! (defmacro defgroup (&rest args) nil) - (defmacro defcustom (var value doc &rest args) - (` (defvar (, var) (, value) (, doc)))))) + (defmacro defcustom (var value doc &rest args) + `(defvar ,var ,value ,doc)))) (if (not (fboundp 'try-font-name)) (defun try-font-name (fontname &rest args) @@ -89,13 +90,12 @@ "Whether we are running in XEmacs or not.") (defmacro define-font-keywords (&rest keys) - (` - (eval-and-compile - (let ((keywords (quote (, keys)))) + `(eval-and-compile + (let ((keywords (quote ,keys))) (while keywords (or (boundp (car keywords)) (set (car keywords) (car keywords))) - (setq keywords (cdr keywords))))))) + (setq keywords (cdr keywords)))))) (defconst font-window-system-mappings '((x . (x-font-create-name x-font-create-object)) @@ -187,37 +187,36 @@ (eval-when-compile (defmacro define-new-mask (attr mask) - (` - (progn + `(progn (setq font-style-keywords - (cons (cons (quote (, attr)) + (cons (cons (quote ,attr) (cons - (quote (, (intern (format "set-font-%s-p" attr)))) - (quote (, (intern (format "font-%s-p" attr)))))) + (quote ,(intern (format "set-font-%s-p" attr))) + (quote ,(intern (format "font-%s-p" attr))))) font-style-keywords)) - (defconst (, (intern (format "font-%s-mask" attr))) (<< 1 (, mask)) - (, (format - "Bitmask for whether a font is to be rendered in %s or not." - attr))) - (defun (, (intern (format "font-%s-p" attr))) (fontobj) - (, (format "Whether FONTOBJ will be renderd in `%s' or not." attr)) + (defconst ,(intern (format "font-%s-mask" attr)) (<< 1 ,mask) + ,(format + "Bitmask for whether a font is to be rendered in %s or not." + attr)) + (defun ,(intern (format "font-%s-p" attr)) (fontobj) + ,(format "Whether FONTOBJ will be renderd in `%s' or not." attr) (if (/= 0 (& (font-style fontobj) - (, (intern (format "font-%s-mask" attr))))) + ,(intern (format "font-%s-mask" attr)))) t nil)) - (defun (, (intern (format "set-font-%s-p" attr))) (fontobj val) - (, (format "Set whether FONTOBJ will be renderd in `%s' or not." - attr)) + (defun ,(intern (format "set-font-%s-p" attr)) (fontobj val) + ,(format "Set whether FONTOBJ will be renderd in `%s' or not." + attr) (cond (val (set-font-style fontobj (| (font-style fontobj) - (, (intern - (format "font-%s-mask" attr)))))) - (((, (intern (format "font-%s-p" attr))) fontobj) + ,(intern + (format "font-%s-mask" attr))))) + ((,(intern (format "font-%s-p" attr)) fontobj) (set-font-style fontobj (- (font-style fontobj) - (, (intern - (format "font-%s-mask" attr)))))))) - )))) + ,(intern + (format "font-%s-mask" attr))))))) + ))) (let ((mask 0)) (define-new-mask bold (setq mask (1+ mask))) @@ -250,7 +249,7 @@ (while (< i 255) ;; Oslash - Thorn (aset table i (- i 32)) (setq i (1+ i))) - table)) + table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utility functions @@ -435,15 +434,14 @@ (make-font :size "12pt")) (defun tty-font-create-plist (fontobj &optional device) - (let ((styles (font-style fontobj)) - (weight (font-weight fontobj))) - (list - (cons 'underline (font-underline-p fontobj)) - (cons 'highlight (if (or (font-bold-p fontobj) - (memq weight '(:bold :demi-bold))) t)) - (cons 'dim (font-dim-p fontobj)) - (cons 'blinking (font-blink-p fontobj)) - (cons 'reverse (font-reverse-p fontobj))))) + (list + (cons 'underline (font-underline-p fontobj)) + (cons 'highlight (if (or (font-bold-p fontobj) + (memq (font-weight fontobj) '(:bold :demi-bold))) + t)) + (cons 'dim (font-dim-p fontobj)) + (cons 'blinking (font-blink-p fontobj)) + (cons 'reverse (font-reverse-p fontobj)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -560,16 +558,13 @@ (set-font-italic-p retval t)) ((member slant '("o" "O")) (set-font-oblique-p retval t))) - (if (string-match font-x-registry-and-encoding-regexp fontname) - (progn - (set-font-registry retval (match-string 1 fontname)) - (set-font-encoding retval (match-string 2 fontname)))) + (when (string-match font-x-registry-and-encoding-regexp fontname) + (set-font-registry retval (match-string 1 fontname)) + (set-font-encoding retval (match-string 2 fontname))) retval)))) (defun x-font-families-for-device (&optional device no-resetp) - (condition-case () - (require 'x-font-menu) - (error nil)) + (ignore-errors (require 'x-font-menu)) (or device (setq device (selected-device))) (if (boundp 'device-fonts-cache) (let ((menu (or (cdr-safe (assq device device-fonts-cache))))) @@ -577,9 +572,9 @@ (progn (reset-device-font-menus device) (x-font-families-for-device device t)) - (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 0))) - (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (normal (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 1)))) (sort (font-unique (nconc scaled normal)) 'string-lessp)))) (cons "monospace" (mapcar 'car font-x-family-mappings)))) @@ -597,40 +592,32 @@ (if (and (fboundp 'fontsetp) (fontsetp font)) (aref (get-font-info (aref (cdr (get-fontset-info font)) 0)) 2) font)))) - + ;;;###autoload (defun font-default-object-for-device (&optional device) (let ((font (font-default-font-for-device device))) - (or (cdr-safe - (assoc font font-default-cache)) - (progn - (setq font-default-cache (cons (cons font - (font-create-object font)) - font-default-cache)) - (cdr-safe (assoc font font-default-cache)))))) + (unless (cdr-safe (assoc font font-default-cache)) + (push (cons font (font-create-object font)) font-default-cache) + (cdr-safe (assoc font font-default-cache))))) ;;;###autoload (defun font-default-family-for-device (&optional device) - (or device (setq device (selected-device))) - (font-family (font-default-object-for-device device))) + (font-family (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-registry-for-device (&optional device) - (or device (setq device (selected-device))) - (font-registry (font-default-object-for-device device))) + (font-registry (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-encoding-for-device (&optional device) - (or device (setq device (selected-device))) - (font-encoding (font-default-object-for-device device))) + (font-encoding (font-default-object-for-device (or device (selected-device))))) ;;;###autoload (defun font-default-size-for-device (&optional device) - (or device (setq device (selected-device))) ;; face-height isn't the right thing (always 1 pixel too high?) ;; (if font-running-xemacs ;; (format "%dpx" (face-height 'default device)) - (font-size (font-default-object-for-device device))) + (font-size (font-default-object-for-device (or device (selected-device))))) (defun x-font-create-name (fontobj &optional device) (if (and (not (or (font-family fontobj) @@ -718,9 +705,9 @@ (progn (reset-device-font-menus device) (ns-font-families-for-device device t)) - (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) + (let ((scaled (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 0))) - (normal (mapcar (function (lambda (x) (if x (aref x 0)))) + (normal (mapcar #'(lambda (x) (if x (aref x 0))) (aref menu 1)))) (sort (font-unique (nconc scaled normal)) 'string-lessp)))))) @@ -778,14 +765,14 @@ ;;; Missing parts of the font spec should be filled in with these values: ;;; Courier New:Regular:10::western ;; "^[a-zA-Z ]+:[a-zA-Z ]*:[0-9]+:[a-zA-Z ]*:[a-zA-Z 0-9]*$" -(defvar font-mswindows-font-regexp +(defvar font-mswindows-font-regexp (let ((- ":") (fontname "\\([a-zA-Z ]+\\)") (weight "\\([a-zA-Z]*\\)") (style "\\( [a-zA-Z]*\\)?") (pointsize "\\([0-9]+\\)") - (effects "\\([a-zA-Z ]*\\)")q + (effects "\\([a-zA-Z ]*\\)") (charset "\\([a-zA-Z 0-9]*\\)") ) (concat "^" @@ -889,7 +876,7 @@ (and (font-bold-p fontobj) :bold))) (if (stringp size) (setq size (truncate (font-spatial-to-canonical size device)))) - (setq weight (or (cdr-safe + (setq weight (or (cdr-safe (assq weight mswindows-font-weight-mappings)) "")) (let ((done nil) ; Did we find a good font yet? (font-name nil) ; font name we are currently checking @@ -928,7 +915,7 @@ ;;; Cache building code ;;;###autoload (defun x-font-build-cache (&optional device) - (let ((hashtable (make-hash-table :test 'equal :size 15)) + (let ((hash-table (make-hash-table :test 'equal :size 15)) (fonts (mapcar 'x-font-create-object (x-list-fonts "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"))) (plist nil) @@ -936,7 +923,7 @@ (while fonts (setq cur (car fonts) fonts (cdr fonts) - plist (cl-gethash (car (font-family cur)) hashtable)) + plist (cl-gethash (car (font-family cur)) hash-table)) (if (not (memq (font-weight cur) (plist-get plist 'weights))) (setq plist (plist-put plist 'weights (cons (font-weight cur) (plist-get plist 'weights))))) @@ -949,8 +936,8 @@ (if (and (font-italic-p cur) (not (memq 'italic (plist-get plist 'styles)))) (setq plist (plist-put plist 'styles (cons 'italic (plist-get plist 'styles))))) - (cl-puthash (car (font-family cur)) plist hashtable)) - hashtable)) + (cl-puthash (car (font-family cur)) plist hash-table)) + hash-table)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1128,7 +1115,7 @@ (?3 . 3) (?d . 13) (?D . 13) (?4 . 4) (?e . 14) (?E . 14) (?5 . 5) (?f . 15) (?F . 15) - (?6 . 6) + (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9))) @@ -1230,7 +1217,7 @@ ((and (vectorp color) (= 3 (length color))) (list (aref color 0) (aref color 1) (aref color 2))) ((and (listp color) (= 3 (length color)) (floatp (car color))) - (mapcar (function (lambda (x) (* x 65535))) color)) + (mapcar #'(lambda (x) (* x 65535)) color)) ((and (listp color) (= 3 (length color))) color) ((or (string-match "^#" color) @@ -1250,7 +1237,7 @@ (font-lookup-rgb-components color))))) (defsubst font-tty-compute-color-delta (col1 col2) - (+ + (+ (* (- (aref col1 0) (aref col2 0)) (- (aref col1 0) (aref col2 0))) (* (- (aref col1 1) (aref col2 1)) @@ -1307,7 +1294,7 @@ (tty (apply 'font-tty-find-closest-color (font-color-rgb-components color))) (ns - (let ((vals (mapcar (function (lambda (x) (>> x 8))) + (let ((vals (mapcar #'(lambda (x) (>> x 8)) (font-color-rgb-components color)))) (apply 'format "RGB%02x%02x%02xff" vals))) (otherwise @@ -1365,7 +1352,7 @@ (if (or (eq face face-at) (and (listp face-at) (memq face face-at))) (setq found t))) found)) - + (defun font-blink-callback () ;; Optimized to never invert the face unless one of the visible windows ;; is showing it. @@ -1383,7 +1370,7 @@ "How often to blink faces" :type 'number :group 'faces) - + (defun font-blink-initialize () (cond ((featurep 'itimer) @@ -1393,10 +1380,10 @@ font-blink-interval font-blink-interval)) ((fboundp 'run-at-time) - (cancel-function-timers 'font-blink-callback) + (cancel-function-timers 'font-blink-callback) (run-at-time font-blink-interval font-blink-interval 'font-blink-callback)) (t nil))) - + (provide 'font) diff -r 76b7d63099ad -r 8626e4521993 lisp/gnuserv.el --- a/lisp/gnuserv.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/gnuserv.el Mon Aug 13 11:07:10 2007 +0200 @@ -68,7 +68,7 @@ ;; ported the server-temp-file-regexp feature from server.el ;; ported server hooks from server.el ;; ported kill-*-query functions from server.el (and made it optional) -;; synced other behaviour with server.el +;; synced other behavior with server.el ;; ;; Jan Vroonhof ;; Customized. diff -r 76b7d63099ad -r 8626e4521993 lisp/help.el --- a/lisp/help.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/help.el Mon Aug 13 11:07:10 2007 +0200 @@ -914,15 +914,11 @@ :type 'boolean :group 'help-appearance) -(defun describe-symbol-find-file (function) - (let ((files load-history) - file) - (while files - (if (memq function (cdr (car files))) - (setq file (car (car files)) - files nil)) - (setq files (cdr files))) - file)) +(defun describe-symbol-find-file (symbol) + (loop for (file . load-data) in load-history + do (when (memq symbol load-data) + (return file)))) + (define-obsolete-function-alias 'describe-function-find-file 'describe-symbol-find-file) @@ -1378,10 +1374,6 @@ (s (process-status p))) (setq tail (cdr tail)) (princ (format "%-13s" (process-name p))) - ;;(if (and (eq system-type 'vax-vms) - ;; (eq s 'signal) - ;; (< (process-exit-status p) NSIG)) - ;; (princ (aref sys_errlist (process-exit-status p)))) (princ s) (if (and (eq s 'exit) (/= (process-exit-status p) 0)) (princ (format " %d" (process-exit-status p)))) diff -r 76b7d63099ad -r 8626e4521993 lisp/hyper-apropos.el --- a/lisp/hyper-apropos.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/hyper-apropos.el Mon Aug 13 11:07:10 2007 +0200 @@ -211,7 +211,7 @@ (defvar hyper-apropos-mode-hook nil "*User function run after hyper-apropos mode initialization. Usage: -\(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).") +\(add-hook 'hyper-apropos-mode-hook #'(lambda () ... your init forms ...)).") ;; ---------------------------------------------------------------------- ;; @@ -380,7 +380,7 @@ ;; ---------------------------------------------------------------------- ;; -;; similar to `describe-key-briefly', copied from prim/help.el by CW +;; similar to `describe-key-briefly', copied from help.el by CW ;;;###autoload (defun hyper-describe-key (key) @@ -452,7 +452,7 @@ (if v (format " (default %s): " v) ": ")) - (mapcar (function (lambda (x) (list (symbol-name x)))) + (mapcar #'(lambda (x) (list (symbol-name x))) (face-list)) nil t nil 'hyper-apropos-face-history))) (list (if (string= val "") @@ -885,14 +885,13 @@ (progn (setq ok t) (copy-face symbol 'hyper-apropos-temp-face 'global) - (mapcar (function - (lambda (property) - (setq symtype (face-property-instance symbol - property)) - (if symtype - (set-face-property 'hyper-apropos-temp-face - property - symtype)))) + (mapcar #'(lambda (property) + (setq symtype (face-property-instance symbol + property)) + (if symtype + (set-face-property 'hyper-apropos-temp-face + property + symtype))) built-in-face-specifiers) (setq font (cons (face-property-instance symbol 'font nil 0 t) (face-property-instance symbol 'font)) diff -r 76b7d63099ad -r 8626e4521993 lisp/info.el --- a/lisp/info.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/info.el Mon Aug 13 11:07:10 2007 +0200 @@ -313,6 +313,8 @@ ;; Use the new macro `with-search-caps-disable-folding' ;; Code: +(eval-when-compile + (condition-case nil (require 'browse-url) (error nil))) (defgroup info nil "The info package for Emacs." @@ -460,6 +462,7 @@ (".info.gz" . "gzip -dc %s") (".info-z" . "gzip -dc %s") (".info.Z" . "uncompress -c %s") + (".bz2" . "bzip2 -dc %s") (".gz" . "gzip -dc %s") (".Z" . "uncompress -c %s") (".zip" . "unzip -c %s") ) @@ -804,12 +807,12 @@ ;; Verify that none of the files we used has changed ;; since we used it. (eval (cons 'and - (mapcar '(lambda (elt) - (let ((curr (file-attributes (car elt)))) - ;; Don't compare the access time. - (if curr (setcar (nthcdr 4 curr) 0)) - (setcar (nthcdr 4 (cdr elt)) 0) - (equal (cdr elt) curr))) + (mapcar #'(lambda (elt) + (let ((curr (file-attributes (car elt)))) + ;; Don't compare the access time. + (if curr (setcar (nthcdr 4 curr) 0)) + (setcar (nthcdr 4 (cdr elt)) 0) + (equal (cdr elt) curr))) Info-dir-file-attributes)))) (insert Info-dir-contents) (let ((dirs (reverse Info-directory-list)) @@ -1022,19 +1025,19 @@ newer) (setq Info-dir-newer-info-files nil) (mapcar - '(lambda (f) - (prog2 - (setq f-mod-time (nth 5 (file-attributes f))) - (setq newer (or (> (car f-mod-time) (car dir-mod-time)) - (and (= (car f-mod-time) (car dir-mod-time)) - (> (car (cdr f-mod-time)) (car (cdr dir-mod-time)))))) - (if (and (file-readable-p f) - newer) - (setq Info-dir-newer-info-files - (cons f Info-dir-newer-info-files))))) + #'(lambda (f) + (prog2 + (setq f-mod-time (nth 5 (file-attributes f))) + (setq newer (or (> (car f-mod-time) (car dir-mod-time)) + (and (= (car f-mod-time) (car dir-mod-time)) + (> (car (cdr f-mod-time)) (car (cdr dir-mod-time)))))) + (if (and (file-readable-p f) + newer) + (setq Info-dir-newer-info-files + (cons f Info-dir-newer-info-files))))) (directory-files (file-name-directory file) 'fullname - ".*\\.info\\(.gz\\|.Z\\|-z\\|.zip\\)?$" + ".*\\.info\\(\\.gz\\|\\.bz2\\|\\.Z\\|-z\\|\\.zip\\)?$" 'nosort t)) Info-dir-newer-info-files)) @@ -1088,22 +1091,22 @@ (let ((tab-width 8) (description-col 0) len) - (mapcar '(lambda (e) - (setq e (cdr e)) ; Drop filename - (setq len (length (concat (car e) - (car (cdr e))))) - (if (> len description-col) - (setq description-col len))) + (mapcar #'(lambda (e) + (setq e (cdr e)) ; Drop filename + (setq len (length (concat (car e) + (car (cdr e))))) + (if (> len description-col) + (setq description-col len))) entries) (setq description-col (+ 5 description-col)) - (mapcar '(lambda (e) - (setq e (cdr e)) ; Drop filename - (insert "* " (car e) ":" (car (cdr e))) - (setq e (car (cdr (cdr e)))) - (while e - (indent-to-column description-col) - (insert (car e) "\n") - (setq e (cdr e)))) + (mapcar #'(lambda (e) + (setq e (cdr e)) ; Drop filename + (insert "* " (car e) ":" (car (cdr e))) + (setq e (car (cdr (cdr e)))) + (while e + (indent-to-column description-col) + (insert (car e) "\n") + (setq e (cdr e)))) entries) (insert "\n"))) @@ -1134,15 +1137,15 @@ "Info files in " directory ":\n\n") (Info-dump-dir-entries (mapcar - '(lambda (f) - (or (Info-extract-dir-entry-from f) - (list 'dummy - (progn - (string-match "\\(.*\\)\\.info\\(.gz\\|.Z\\|-z\\|.zip\\)?$" - (file-name-nondirectory f)) - (capitalize (match-string 1 (file-name-nondirectory f)))) - ":" - (list Info-no-description-string)))) + #'(lambda (f) + (or (Info-extract-dir-entry-from f) + (list 'dummy + (progn + (string-match "\\(.*\\)\\.info\\(.gz\\|.Z\\|-z\\|.zip\\)?$" + (file-name-nondirectory f)) + (capitalize (match-string 1 (file-name-nondirectory f)))) + ":" + (list Info-no-description-string)))) info-files)) (if to-temp (set-buffer-modified-p nil) @@ -1199,33 +1202,34 @@ (narrow-to-region mark next-section) (setq dir-section-contents (nreverse (Info-parse-dir-entries (point-min) (point-max)))) - (mapcar '(lambda (file) - (setq dir-entry (assoc (downcase - (file-name-sans-extension - (file-name-nondirectory file))) - dir-section-contents) - file-dir-entry (Info-extract-dir-entry-from file)) - (if dir-entry - (if file-dir-entry - ;; A dir entry in the info file takes precedence over an - ;; existing entry in the dir file - (setcdr dir-entry (cdr file-dir-entry))) - (unless (or not-first-section - (assoc (downcase + (mapcar + #'(lambda (file) + (setq dir-entry (assoc (downcase (file-name-sans-extension (file-name-nondirectory file))) - dir-full-contents)) - (if file-dir-entry - (setq dir-section-contents (cons file-dir-entry - dir-section-contents)) - (setq dir-section-contents - (cons (list 'dummy - (capitalize (file-name-sans-extension - (file-name-nondirectory file))) - ":" - (list Info-no-description-string)) - dir-section-contents)))))) - Info-dir-newer-info-files) + dir-section-contents) + file-dir-entry (Info-extract-dir-entry-from file)) + (if dir-entry + (if file-dir-entry + ;; A dir entry in the info file takes precedence over an + ;; existing entry in the dir file + (setcdr dir-entry (cdr file-dir-entry))) + (unless (or not-first-section + (assoc (downcase + (file-name-sans-extension + (file-name-nondirectory file))) + dir-full-contents)) + (if file-dir-entry + (setq dir-section-contents (cons file-dir-entry + dir-section-contents)) + (setq dir-section-contents + (cons (list 'dummy + (capitalize (file-name-sans-extension + (file-name-nondirectory file))) + ":" + (list Info-no-description-string)) + dir-section-contents)))))) + Info-dir-newer-info-files) (delete-region (point-min) (point-max)) (Info-dump-dir-entries (nreverse dir-section-contents)) (widen) @@ -1372,15 +1376,12 @@ (format (cdr (car suff)) file) (concat (cdr (car suff)) " < " file)))) (message "%s..." command) - (if (eq system-type 'vax-vms) - (call-process command nil t nil) - (call-process shell-file-name nil t nil "-c" command)) + (call-process shell-file-name nil t nil "-c" command) (message "") - (if visit - (progn - (setq buffer-file-name file) - (set-buffer-modified-p nil) - (clear-visited-file-modtime)))) + (when visit + (setq buffer-file-name file) + (set-buffer-modified-p nil) + (clear-visited-file-modtime))) (insert-file-contents file visit)))) (defun Info-select-node () @@ -2779,6 +2780,7 @@ ;; #### The console-on-window-system-p check is to allow this to ;; work on tty's. The real problem here is that featurep really ;; needs to have some device/console domain knowledge added to it. + (defvar info::toolbar) (if (and (featurep 'toolbar) (console-on-window-system-p) (not Info-inhibit-toolbar)) diff -r 76b7d63099ad -r 8626e4521993 lisp/itimer.el --- a/lisp/itimer.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/itimer.el Mon Aug 13 11:07:10 2007 +0200 @@ -717,8 +717,7 @@ (inhibit-quit nil) ;; for FSF Emacs timer.el emulation under XEmacs. ;; eldoc expect this to be done, apparently. - (this-command nil) - itimer itimers time-elapsed) + (this-command nil)) (if (itimer-uses-arguments current-itimer) (apply (itimer-function current-itimer) (itimer-function-arguments current-itimer)) diff -r 76b7d63099ad -r 8626e4521993 lisp/lib-complete.el --- a/lisp/lib-complete.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/lib-complete.el Mon Aug 13 11:07:10 2007 +0200 @@ -38,7 +38,7 @@ ;; Last Modified By: Heiko M|nkel ;; Additional XEmacs integration By: Chuck Thompson ;; Last Modified On: Thu Jul 1 14:23:00 1994 -;; RCS Info : $Revision: 1.3 $ $Locker: $ +;; RCS Info : $Revision: 1.3.2.1 $ $Locker: $ ;; ======================================================================== ;; NOTE: XEmacs must be redumped if this file is changed. ;; @@ -104,25 +104,24 @@ ;;=== Utilities =========================================================== -(defmacro progn-with-message (MESSAGE &rest FORMS) +(defmacro progn-with-message (message &rest forms) "(progn-with-message MESSAGE FORMS ...) Display MESSAGE and evaluate FORMS, returning value of the last one." ;; based on Hallvard Furuseth's funcall-with-message - (` - (if (eq (selected-window) (minibuffer-window)) + `(if (eq (selected-window) (minibuffer-window)) (save-excursion (goto-char (point-max)) (let ((orig-pmax (point-max))) (unwind-protect (progn - (insert " " (, MESSAGE)) (goto-char orig-pmax) + (insert " " ,message) (goto-char orig-pmax) (sit-for 0) ; Redisplay - (,@ FORMS)) + ,@forms) (delete-region orig-pmax (point-max))))) (prog2 - (message "%s" (, MESSAGE)) - (progn (,@ FORMS)) - (message ""))))) + (message "%s" ,message) + (progn ,@forms) + (message "")))) (put 'progn-with-message 'lisp-indent-hook 1) @@ -218,6 +217,7 @@ (if tail (setcdr tail nil))))) ;;=== Read a filename, with completion in a search path =================== +(defvar read-library-internal-search-path) (defun read-library-internal (FILE FILTER FLAG) "Don't call this." diff -r 76b7d63099ad -r 8626e4521993 lisp/lisp-mnt.el --- a/lisp/lisp-mnt.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/lisp-mnt.el Mon Aug 13 11:07:10 2007 +0200 @@ -449,17 +449,17 @@ (switch-to-buffer (get-buffer-create "*lm-verify*")) (erase-buffer) (mapcar - '(lambda (f) - (if (string-match ".*\\.el$" f) - (let ((status (lm-verify f))) - (if status - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column status "\n")) - (and showok - (progn - (insert f ":") - (lm-insert-at-column lm-comment-column "OK\n"))))))) + #'(lambda (f) + (if (string-match ".*\\.el$" f) + (let ((status (lm-verify f))) + (if status + (progn + (insert f ":") + (lm-insert-at-column lm-comment-column status "\n")) + (and showok + (progn + (insert f ":") + (lm-insert-at-column lm-comment-column "OK\n"))))))) (directory-files file)) )) (save-excursion diff -r 76b7d63099ad -r 8626e4521993 lisp/loaddefs.el --- a/lisp/loaddefs.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/loaddefs.el Mon Aug 13 11:07:10 2007 +0200 @@ -86,15 +86,10 @@ ;; making it more likely you will get a unique match. (setq completion-ignored-extensions (mapcar 'purecopy - (if (eq system-type 'vax-vms) - '(".obj" ".elc" ".exe" ".bin" ".lbin" ".sbin" - ".dvi" ".toc" ".log" ".aux" - ".lof" ".brn" ".rnt" ".mem" ".lni" ".lis" - ".olb" ".tlb" ".mlb" ".hlb" ".glo" ".idx" ".lot" ".fmt") - '(".o" ".elc" "~" ".bin" ".lbin" ".fasl" - ".dvi" ".toc" ".log" ".aux" ".a" ".ln" - ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot" ".fmt" - ".diff" ".oi" ".class")))) + '(".o" ".elc" "~" ".bin" ".lbin" ".fasl" + ".dvi" ".toc" ".log" ".aux" ".a" ".ln" + ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot" ".fmt" + ".diff" ".oi" ".class"))) ;; This needs to be redone better. -slb diff -r 76b7d63099ad -r 8626e4521993 lisp/loadhist.el --- a/lisp/loadhist.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/loadhist.el Mon Aug 13 11:07:10 2007 +0200 @@ -34,81 +34,69 @@ ;;; Code: +;; load-history is a list of entries that look like this: +;; ("outline" outline-regexp ... (require . wid-edit) ... (provide . outline) ...) + (defun symbol-file (sym) "Return the input source from which SYM was loaded. This is a file name, or nil if the source was a buffer with no associated file." (interactive "SFind source file for symbol: ") ; XEmacs - (catch 'foundit - (mapcar - (function (lambda (x) (if (memq sym (cdr x)) (throw 'foundit (car x))))) - load-history) - nil)) + (dolist (entry load-history) + (when (memq sym (cdr entry)) + (return (car entry))))) (defun feature-symbols (feature) "Return the file and list of symbols associated with a given FEATURE." - (catch 'foundit - (mapcar - (function (lambda (x) - (if (member (cons 'provide feature) (cdr x)) - (throw 'foundit x)))) - load-history) - nil)) + (let ((pair `(provide . ,feature))) + (dolist (entry load-history) + (when (member pair (cdr entry)) + (return entry))))) (defun feature-file (feature) "Return the file name from which a given FEATURE was loaded. Actually, return the load argument, if any; this is sometimes the name of a Lisp file without an extension. If the feature came from an eval-buffer on a buffer with no associated file, or an eval-region, return nil." - (if (not (featurep feature)) - (error "%s is not a currently loaded feature" (symbol-name feature)) - (car (feature-symbols feature)))) + (unless (featurep feature) + (error "%s is not a currently loaded feature" (symbol-name feature))) + (car (feature-symbols feature))) + +(defun file-symbols (file) + "Return the file and list of symbols associated with FILE. +The file name in the returned list is the string used to load the file, +and may not be the same string as FILE, but it will be equivalent." + (or (assoc file load-history) + (assoc (file-name-sans-extension file) load-history) + (assoc (concat file ".el") load-history) + (assoc (concat file ".elc") load-history))) (defun file-provides (file) "Return the list of features provided by FILE." - (let ((symbols (or (cdr (assoc file load-history)) - (cdr (assoc (file-name-sans-extension file) load-history)) - (cdr (assoc (concat file ".el") load-history)) - (cdr (assoc (concat file ".elc") load-history)))) - (provides nil)) - (mapcar - (function (lambda (x) - (if (and (consp x) (eq (car x) 'provide)) - (setq provides (cons (cdr x) provides))))) - symbols) - provides - )) + (let ((provides nil)) + (dolist (x (cdr (file-symbols file))) + (when (eq (car-safe x) 'provide) + (push (cdr x) provides))) + provides)) (defun file-requires (file) "Return the list of features required by FILE." - (let ((symbols (cdr (assoc file load-history))) (requires nil)) - (mapcar - (function (lambda (x) - (if (and (consp x) (eq (car x) 'require)) - (setq requires (cons (cdr x) requires))))) - symbols) - requires - )) - -(defun file-set-intersect (p q) - ;; Return the set intersection of two lists - (let ((ret nil)) - (mapcar - (function (lambda (x) (if (memq x q) (setq ret (cons x ret))))) - p) - ret - )) + (let ((requires nil)) + (dolist (x (cdr (file-symbols file))) + (when (eq (car-safe x) 'require) + (push (cdr x) requires))) + requires)) (defun file-dependents (file) "Return the list of loaded libraries that depend on FILE. This can include FILE itself." - (let ((provides (file-provides file)) (dependents nil)) - (mapcar - (function (lambda (x) - (if (file-set-intersect provides (file-requires (car x))) - (setq dependents (cons (car x) dependents))))) - load-history) - dependents - )) + (let ((provides (file-provides file)) + (dependents nil)) + (dolist (entry load-history) + (dolist (x (cdr entry)) + (when (and (eq (car-safe x) 'require) + (memq (cdr-safe x) provides)) + (push (car entry) dependents)))) + dependents)) ;; FSFmacs ;(defun read-feature (prompt) @@ -116,8 +104,8 @@ ;prompting with PROMPT and completing from `features', and ;return the feature \(symbol\)." ; (intern (completing-read prompt -; (mapcar (function (lambda (feature) -; (list (symbol-name feature)))) +; (mapcar #'(lambda (feature) +; (list (symbol-name feature))) ; features) ; nil t))) @@ -127,28 +115,27 @@ If the feature is required by any other loaded code, and optional FORCE is nil, raise an error." (interactive "SFeature: ") - (if (not (featurep feature)) - (error "%s is not a currently loaded feature" (symbol-name feature))) - (if (not force) - (let* ((file (feature-file feature)) - (dependents (delete file (copy-sequence (file-dependents file))))) - (if dependents - (error "Loaded libraries %s depend on %s" - (prin1-to-string dependents) file) - ))) + (unless (featurep feature) + (error "%s is not a currently loaded feature" (symbol-name feature))) + (when (not force) + (let* ((file (feature-file feature)) + (dependents (delete file (copy-sequence (file-dependents file))))) + (when dependents + (error "Loaded libraries %s depend on %s" + (prin1-to-string dependents) file)))) (let* ((flist (feature-symbols feature)) (file (car flist))) (mapcar - (function (lambda (x) - (cond ((stringp x) nil) - ((consp x) - ;; Remove any feature names that this file provided. - (if (eq (car x) 'provide) - (setq features (delq (cdr x) features)))) - ((boundp x) (makunbound x)) - ((fboundp x) - (fmakunbound x) - (let ((aload (get x 'autoload))) - (if aload (fset x (cons 'autoload aload)))))))) + #'(lambda (x) + (cond ((stringp x) nil) + ((consp x) + ;; Remove any feature names that this file provided. + (if (eq (car x) 'provide) + (setq features (delq (cdr x) features)))) + ((boundp x) (makunbound x)) + ((fboundp x) + (fmakunbound x) + (let ((aload (get x 'autoload))) + (if aload (fset x (cons 'autoload aload))))))) (cdr flist)) ;; Delete the load-history element for this file. (let ((elt (assoc file load-history))) diff -r 76b7d63099ad -r 8626e4521993 lisp/loadup.el --- a/lisp/loadup.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/loadup.el Mon Aug 13 11:07:10 2007 +0200 @@ -34,14 +34,17 @@ ;;; Code: -(if (fboundp 'error) - (error "loadup.el already loaded!")) +(when (fboundp 'error) + (error "loadup.el already loaded!")) (defvar running-xemacs t "Non-nil when the current emacs is XEmacs.") (defvar preloaded-file-list nil "List of files preloaded into the XEmacs binary image.") + +(let ((gc-cons-threshold 30000)) + ;; This is awfully damn early to be getting an error, right? (call-with-condition-handler 'really-early-error-handler #'(lambda () @@ -79,11 +82,9 @@ ;; there will be lots of extra space in the data segment filled ;; with garbage-collected junk) (defun pureload (file) - (let ((full-path (locate-file file - load-path - (if load-ignore-elc-files - ".el:" - ".elc:.el:")))) + (let ((full-path + (locate-file file load-path + (if load-ignore-elc-files ".el:" ".elc:.el:")))) (if full-path (prog1 (load full-path) @@ -100,16 +101,14 @@ (let ((files preloaded-file-list) file) (while (setq file (car files)) - (or (pureload file) - (progn - (external-debugging-output "Fatal error during load, aborting") - (kill-emacs 1))) + (unless (pureload file) + (external-debugging-output "Fatal error during load, aborting") + (kill-emacs 1)) (setq files (cdr files))) - (if (not (featurep 'toolbar)) - (progn - ;; else still define a few functions. - (defun toolbar-button-p (obj) "No toolbar support." nil) - (defun toolbar-specifier-p (obj) "No toolbar support." nil))) + (when (not (featurep 'toolbar)) + ;; else still define a few functions. + (defun toolbar-button-p (obj) "No toolbar support." nil) + (defun toolbar-specifier-p (obj) "No toolbar support." nil)) (fmakunbound 'pureload)) (packages-load-package-dumped-lisps late-package-load-path) @@ -134,8 +133,8 @@ ;; But you must also cause them to be scanned when the DOC file ;; is generated. For VMS, you must edit ../../vms/makedoc.com. ;; For other systems, you must edit ../../src/Makefile.in.in. -(if (load "site-load" t) - (garbage-collect)) +(when (load "site-load" t) + (garbage-collect)) ;;FSFmacs randomness ;;(if (fboundp 'x-popup-menu) @@ -158,29 +157,30 @@ (message "Finding pointers to doc strings...") (Snarf-documentation "DOC") (message "Finding pointers to doc strings...done") - (Verify-documentation) - ) + (Verify-documentation)) ;; Note: You can cause additional libraries to be preloaded ;; by writing a site-init.el that loads them. ;; See also "site-load" above. -(if (stringp site-start-file) - (load "site-init" t)) +(when (stringp site-start-file) + (load "site-init" t)) (setq current-load-list nil) (garbage-collect) ;;; At this point, we're ready to resume undo recording for scratch. (buffer-enable-undo "*scratch*") +) ;; frequent garbage collection + ;; Dump into the name `xemacs' (only) (when (member "dump" command-line-args) - (message "Dumping under the name xemacs") - ;; This is handled earlier in the build process. - ;; (condition-case () (delete-file "xemacs") (file-error nil)) - (when (fboundp 'really-free) - (really-free)) - (dump-emacs (if (featurep 'infodock) "infodock" "xemacs") "temacs") - (kill-emacs)) + (message "Dumping under the name xemacs") + ;; This is handled earlier in the build process. + ;; (condition-case () (delete-file "xemacs") (file-error nil)) + (when (fboundp 'really-free) + (really-free)) + (dump-emacs (if (featurep 'infodock) "infodock" "xemacs") "temacs") + (kill-emacs)) ;; Avoid error if user loads some more libraries now. (setq purify-flag nil) @@ -197,9 +197,9 @@ ;; so that the .el files always get loaded (the .elc files may be out-of- ;; date or bad). (when (member "recompile" command-line-args) - (let ((command-line-args-left (cdr (member "recompile" command-line-args)))) - (batch-byte-recompile-directory) - (kill-emacs))) + (setq command-line-args-left (cdr (member "recompile" command-line-args))) + (batch-byte-recompile-directory) + (kill-emacs)) ;; For machines with CANNOT_DUMP defined in config.h, ;; this file must be loaded each time Emacs is run. diff -r 76b7d63099ad -r 8626e4521993 lisp/make-docfile.el --- a/lisp/make-docfile.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/make-docfile.el Mon Aug 13 11:07:10 2007 +0200 @@ -171,7 +171,7 @@ nil "-fc" (mapconcat - 'identity + #'identity (append (list (concat default-directory "../lib-src/make-docfile")) options processed) diff -r 76b7d63099ad -r 8626e4521993 lisp/map-ynp.el --- a/lisp/map-ynp.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/map-ynp.el Mon Aug 13 11:07:10 2007 +0200 @@ -90,15 +90,14 @@ (compiled-function-p list) (and (consp list) (eq (car list) 'lambda))) - (function (lambda () - (setq elt (funcall list)))) - (function (lambda () - (if list - (progn - (setq elt (car list) - list (cdr list)) - t) - nil)))))) + #'(lambda () (setq elt (funcall list))) + #'(lambda () + (if list + (progn + (setq elt (car list) + list (cdr list)) + t) + nil))))) (if (should-use-dialog-box-p) ;; Make a list describing a dialog box. (let (;; (object (capitalize (or (nth 0 help) "object"))) @@ -123,19 +122,18 @@ ("Yes All" . automatic) ("No All" . exit) ("Cancel" . quit) - ,@(mapcar (lambda (elt) - (cons (capitalize (nth 2 elt)) - (vector (nth 1 elt)))) + ,@(mapcar #'(lambda (elt) + (cons (capitalize (nth 2 elt)) + (vector (nth 1 elt)))) action-alist)) mouse-event last-command-event)) (setq user-keys (if action-alist - (concat (mapconcat (function - (lambda (elt) - (key-description - (if (characterp (car elt)) - ;; XEmacs - (char-to-string (car elt)) - (car elt))))) + (concat (mapconcat #'(lambda (elt) + (key-description + (if (characterp (car elt)) + ;; XEmacs + (char-to-string (car elt)) + (car elt)))) action-alist ", ") " ") "") @@ -156,8 +154,8 @@ (unwind-protect (progn (if (stringp prompter) - (setq prompter (` (lambda (object) - (format (, prompter) object))))) + (setq prompter `(lambda (object) + (format ,prompter object)))) (while (funcall next) (setq prompt (funcall prompter elt)) (cond ((stringp prompt) @@ -186,7 +184,7 @@ (single-key-description char)))) (setq def (lookup-key map (vector char)))) (cond ((eq def 'exit) - (setq next (function (lambda () nil)))) + (setq next #'(lambda () nil))) ((eq def 'act) ;; Act on the object. (funcall actor elt) @@ -201,9 +199,9 @@ next (function (lambda () nil)))) ((or (eq def 'quit) (eq def 'exit-prefix)) (setq quit-flag t) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))) + (setq next `(lambda () + (setq next ',next) + ',elt))) ((eq def 'automatic) ;; Act on this and all following objects. ;; (if (funcall prompter elt) ; Emacs @@ -244,34 +242,34 @@ (set-buffer standard-output) (help-mode))) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))) + (setq next `(lambda () + (setq next ',next) + ',elt))) ((vectorp def) ;; A user-defined key. (if (funcall (aref def 0) elt) ;Call its function. ;; The function has eaten this object. (setq actions (1+ actions)) ;; Regurgitated; try again. - (setq next (` (lambda () - (setq next '(, next)) - '(, elt)))))) + (setq next `(lambda () + (setq next ',next) + ',elt)))) ;((and (consp char) ; Emacs ; (eq (car char) 'switch-frame)) ; ;; switch-frame event. Put it off until we're done. ; (setq delayed-switch-frame char) - ; (setq next (` (lambda () - ; (setq next '(, next)) - ; '(, elt))))) + ; (setq next `(lambda () + ; (setq next ',next) + ; ',elt))) (t ;; Random char. (message "Type %s for help." (key-description (vector help-char))) (beep) (sit-for 1) - (setq next (` (lambda () - (setq next '(, next)) - '(, elt))))))) + (setq next `(lambda () + (setq next ',next) + ',elt))))) ((eval prompt) (progn (funcall actor elt) diff -r 76b7d63099ad -r 8626e4521993 lisp/menubar.el --- a/lisp/menubar.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/menubar.el Mon Aug 13 11:07:10 2007 +0200 @@ -171,8 +171,8 @@ menuitem))) ))) ) - ;; (t (signal 'error (list "unrecognised menu descriptor" menuitem)))) - (t (message "unrecognised menu descriptor %s" (prin1-to-string menuitem)))) + ;; (t (signal 'error (list "unrecognized menu descriptor" menuitem)))) + (t (message "unrecognized menu descriptor %s" (prin1-to-string menuitem)))) (setq menu (cdr menu))))) diff -r 76b7d63099ad -r 8626e4521993 lisp/minibuf.el --- a/lisp/minibuf.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/minibuf.el Mon Aug 13 11:07:10 2007 +0200 @@ -41,7 +41,7 @@ ;;; Code: (defgroup minibuffer nil - "Controling the behaviour of the minibuffer." + "Controling the behavior of the minibuffer." :group 'environment) @@ -350,7 +350,7 @@ to be inserted into the minibuffer before reading input. If INITIAL-CONTENTS is (STRING . POSITION), the initial input is STRING, but point is placed POSITION characters into the string. -Third arg KEYMAP is a keymap to use whilst reading; +Third arg KEYMAP is a keymap to use while reading; if omitted or nil, the default is `minibuffer-local-map'. If fourth arg READ is non-nil, then interpret the result as a lisp object and return that object: @@ -1477,24 +1477,21 @@ (olen (length string)) new n o ch) - (cond ((eq system-type 'vax-vms) - string) - ((not (string-match regexp string)) - string) - (t - (setq n 1) - (while (string-match regexp string (match-end 0)) - (setq n (1+ n))) - (setq new (make-string (+ olen n) ?$)) - (setq n 0 o 0) - (while (< o olen) - (setq ch (aref string o)) - (aset new n ch) - (setq o (1+ o) n (1+ n)) - (if (eq ch ?$) - ;; already aset by make-string initial-value - (setq n (1+ n)))) - new)))) + (if (not (string-match regexp string)) + string + (setq n 1) + (while (string-match regexp string (match-end 0)) + (setq n (1+ n))) + (setq new (make-string (+ olen n) ?$)) + (setq n 0 o 0) + (while (< o olen) + (setq ch (aref string o)) + (aset new n ch) + (setq o (1+ o) n (1+ n)) + (if (eq ch ?$) + ;; already aset by make-string initial-value + (setq n (1+ n)))) + new))) (defun read-file-name-2 (history prompt dir default must-match initial-contents @@ -1511,8 +1508,7 @@ (length dir))) (t (un-substitute-in-file-name dir)))) - (val (let ((completion-ignore-case (or completion-ignore-case - (eq system-type 'vax-vms)))) + (val ;; Hateful, broken, case-sensitive un*x ;;; (completing-read prompt ;;; completer @@ -1520,22 +1516,22 @@ ;;; must-match ;;; insert ;;; history) - ;; #### - this is essentially the guts of completing read. - ;; There should be an elegant way to pass a pair of keymaps to - ;; completing read, but this will do for now. All sins are - ;; relative. --Stig - (let ((minibuffer-completion-table completer) - (minibuffer-completion-predicate dir) - (minibuffer-completion-confirm (if (eq must-match 't) - nil t)) - (last-exact-completion nil)) - (read-from-minibuffer prompt - insert - (if (not must-match) - read-file-name-map - read-file-name-must-match-map) - nil - history))) + ;; #### - this is essentially the guts of completing read. + ;; There should be an elegant way to pass a pair of keymaps to + ;; completing read, but this will do for now. All sins are + ;; relative. --Stig + (let ((minibuffer-completion-table completer) + (minibuffer-completion-predicate dir) + (minibuffer-completion-confirm (if (eq must-match 't) + nil t)) + (last-exact-completion nil)) + (read-from-minibuffer prompt + insert + (if (not must-match) + read-file-name-map + read-file-name-must-match-map) + nil + history)) )) ;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar" ;;; (let ((hist (cond ((not history) 'minibuffer-history) @@ -1728,7 +1724,7 @@ (alist #'(lambda () (mapcar #'(lambda (x) (cons (substring x 0 (string-match "=" x)) - 'nil)) + nil)) process-environment)))) (cond ((eq action 'lambda) @@ -1743,7 +1739,7 @@ (concat "$" p) (concat head "$" p))) (all-completions env (funcall alist)))) - (t ;; 'nil + (t ;; nil ;; complete (let* ((e (funcall alist)) (val (try-completion env e))) @@ -1779,7 +1775,7 @@ ;; all completions (mapcar #'un-substitute-in-file-name (file-name-all-completions name dir))) - (t;; 'nil + (t;; nil ;; complete (let* ((d (or dir default-directory)) (val (file-name-completion name d))) @@ -1820,11 +1816,8 @@ nil 'directories)))) (mapcar fn - (cond ((eq system-type 'vax-vms) - l) - (t - ;; Wretched unix - (delete "." l)))))))) + ;; Wretched unix + (delete "." l)))))) (cond ((eq action 'lambda) ;; complete? (if (not orig) diff -r 76b7d63099ad -r 8626e4521993 lisp/modeline.el --- a/lisp/modeline.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/modeline.el Mon Aug 13 11:07:10 2007 +0200 @@ -81,7 +81,7 @@ (start-nwindows (count-windows t)) ;; (hscroll-delta (face-width 'modeline)) ;; (start-hscroll (modeline-hscroll (event-window event))) - (start-x-pixel (event-x-pixel event)) +; (start-x-pixel (event-x-pixel event)) (last-timestamp 0) default-line-height modeline-height @@ -220,7 +220,7 @@ "Handle mouse clicks on modeline by switching buffers. If click on left half of a frame's modeline, bury current buffer. If click on right half of a frame's modeline, raise bottommost buffer. -Arg EVENT is the button release event that occured on the modeline." +Arg EVENT is the button release event that occurred on the modeline." (or (event-over-modeline-p event) (error "not over a modeline")) (or (button-release-event-p event) diff -r 76b7d63099ad -r 8626e4521993 lisp/mouse.el --- a/lisp/mouse.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/mouse.el Mon Aug 13 11:07:10 2007 +0200 @@ -68,13 +68,13 @@ :group 'mouse) (defcustom mouse-highlight-text 'context - "*Choose the default double-click highlighting behaviour. + "*Choose the default double-click highlighting behavior. If set to `context', double-click will highlight words when the mouse is at a word character, or a symbol if the mouse is at a symbol character. If set to `word', double-click will always attempt to highlight a word. If set to `symbol', double-click will always attempt to highlight a - symbol (the default behaviour in previous XEmacs versions)." + symbol (the default behavior in previous XEmacs versions)." :type '(choice (const context) (const word) (const symbol)) @@ -960,7 +960,7 @@ ;; always sufficient but it seems to give something ;; approaching a 99% success rate. Making it higher yet ;; would help guarantee success with the price that the - ;; delay would start to become noticable. + ;; delay would start to become noticeable. ;; (and (eq (console-type) 'x) (sit-for 0.15 t)) diff -r 76b7d63099ad -r 8626e4521993 lisp/obsolete.el --- a/lisp/obsolete.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/obsolete.el Mon Aug 13 11:07:10 2007 +0200 @@ -346,7 +346,7 @@ ;; ### This function is not compatible with FSF in some cases. Hard ;; to fix, because it is hard to trace the logic of the FSF function. -;; In case we need the exact behaviour, we can always copy the FSF +;; In case we need the exact behavior, we can always copy the FSF ;; version, which is very long and does lots of unnecessary stuff. (defun truncate-string-to-width (str end-column &optional start-column padding) "Truncate string STR to end at column END-COLUMN. @@ -377,4 +377,5 @@ (make-obsolete 'function-called-at-point 'function-at-point) +(provide 'obsolete) ;;; obsolete.el ends here diff -r 76b7d63099ad -r 8626e4521993 lisp/package-admin.el --- a/lisp/package-admin.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/package-admin.el Mon Aug 13 11:07:10 2007 +0200 @@ -432,7 +432,8 @@ ;; Delete empty directories. (if dirs (let ( (orig-default-directory default-directory) - directory files file ) +; directory files file + ) ;; Make sure we preserve the existing `default-directory'. ;; JV, why does this change the default directory? Does it indeed? (unwind-protect diff -r 76b7d63099ad -r 8626e4521993 lisp/package-get.el --- a/lisp/package-get.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/package-get.el Mon Aug 13 11:07:10 2007 +0200 @@ -609,7 +609,6 @@ (mapcar #'(lambda (reqd) (let* ((reqd-package (package-get-package-provider reqd)) - (reqd-version (cadr reqd-package)) (reqd-name (car reqd-package))) (if (null reqd-name) (error "Unable to find a provider for %s" reqd)) diff -r 76b7d63099ad -r 8626e4521993 lisp/paragraphs.el --- a/lisp/paragraphs.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/paragraphs.el Mon Aug 13 11:07:10 2007 +0200 @@ -57,7 +57,7 @@ Prefix argument says to turn mode on if positive, off if negative. When the mode is turned on, if there are newlines in the buffer but no hard -newlines, ask the user whether to mark as hard any newlines preceeding a +newlines, ask the user whether to mark as hard any newlines preceding a `paragraph-start' line. From a program, second arg INSERT specifies whether to do this; it can be `never' to change nothing, t or `always' to force marking, `guess' to try to do the right thing with no questions, nil diff -r 76b7d63099ad -r 8626e4521993 lisp/paths.el --- a/lisp/paths.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/paths.el Mon Aug 13 11:07:10 2007 +0200 @@ -118,8 +118,7 @@ (defconst remote-shell-program nil "Program used to execute shell commands on a remote machine.") -(defconst term-file-prefix - (purecopy (if (eq system-type 'vax-vms) "[.term]" "term/")) +(defconst term-file-prefix (purecopy "term/") "If non-nil, Emacs startup does (load (concat term-file-prefix (getenv \"TERM\"))) You may set this variable to nil in your `.emacs' file if you do not wish the terminal-initialization file to be loaded.") @@ -127,10 +126,7 @@ (defconst manual-program nil "Program to run to print man pages.") -(defconst abbrev-file-name - (purecopy (if (eq system-type 'vax-vms) - "~/abbrev.def" - "~/.abbrev_defs")) +(defconst abbrev-file-name (purecopy "~/.abbrev_defs") "*Default name of file to read abbrevs from.") (defconst directory-abbrev-alist diff -r 76b7d63099ad -r 8626e4521993 lisp/process.el --- a/lisp/process.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/process.el Mon Aug 13 11:07:10 2007 +0200 @@ -33,6 +33,9 @@ ;;; Code: +(defvar binary-process-output) +(defvar buffer-file-type) + (defgroup processes nil "Process, subshell, compilation, and job control support." :group 'external @@ -62,14 +65,10 @@ Third arg is command name, the name of a shell command. Remaining arguments are the arguments for the command. Wildcards and redirection are handled as usual in the shell." - (cond - ((eq system-type 'vax-vms) - (apply 'start-process name buffer args)) - ;; We used to use `exec' to replace the shell with the command, - ;; but that failed to handle (...) and semicolon, etc. - (t - (start-process name buffer shell-file-name shell-command-switch - (mapconcat 'identity args " "))))) + ;; We used to use `exec' to replace the shell with the command, + ;; but that failed to handle (...) and semicolon, etc. + (start-process name buffer shell-file-name shell-command-switch + (mapconcat #'identity args " "))) (defun call-process (program &optional infile buffer displayp &rest args) "Call PROGRAM synchronously in separate process. @@ -114,31 +113,19 @@ and returns a numeric exit status or a signal description string. If you quit, the process is first killed with SIGINT, then with SIGKILL if you quit again before the process exits." - (let ((temp (cond ((eq system-type 'vax-vms) - (make-temp-name "tmp:emacs")) - ((or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "em"))) - (t - (make-temp-name - (concat (file-name-as-directory - (temp-directory)) - "emacs")))))) + (let ((temp + (make-temp-name + (concat (file-name-as-directory (temp-directory)) + (if (memq system-type '(ms-dos windows-nt)) "em" "emacs"))))) (unwind-protect (progn - (if (or (eq system-type 'ms-dos) - (eq system-type 'windows-nt)) + (if (memq system-type '(ms-dos windows-nt)) (let ((buffer-file-type binary-process-output)) (write-region start end temp nil 'silent)) (write-region start end temp nil 'silent)) (if deletep (delete-region start end)) (apply #'call-process program temp buffer displayp args)) - (condition-case () - (delete-file temp) - (file-error nil))))) + (ignore-file-errors (delete-file temp))))) (defun shell-command (command &optional output-buffer) @@ -188,7 +175,7 @@ ;; in the buffer itself. (defun shell-command-sentinel (process signal) (if (memq (process-status process) '(exit signal)) - (message "%s: %s." + (message "%s: %s." (car (cdr (cdr (process-command process)))) (substring signal 0 -1)))) @@ -260,7 +247,7 @@ shell-file-name t t nil shell-command-switch command)) (setq success t)) - ;; Clear the output buffer, + ;; Clear the output buffer, ;; then run the command with output there. (save-excursion (set-buffer buffer) @@ -295,7 +282,7 @@ (buffer-substring (point) (progn (end-of-line) (point)))))) - (t + (t (set-window-start (display-buffer buffer) 1)))))))) diff -r 76b7d63099ad -r 8626e4521993 lisp/select.el --- a/lisp/select.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/select.el Mon Aug 13 11:07:10 2007 +0200 @@ -273,7 +273,7 @@ ;; why is killed-rectangle free? Is it used somewhere? ;; should it be defvarred? (setq killed-rectangle (extract-rectangle s e)) - (kill-new (mapconcat 'identity killed-rectangle "\n"))) + (kill-new (mapconcat #'identity killed-rectangle "\n"))) (copy-region-as-kill s e)) ;; Maybe killing doesn't own clipboard. Make sure it happens. ;; This memq is kind of grody, because they might have done it diff -r 76b7d63099ad -r 8626e4521993 lisp/setup-paths.el --- a/lisp/setup-paths.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/setup-paths.el Mon Aug 13 11:07:10 2007 +0200 @@ -111,10 +111,12 @@ (defun paths-find-lock-directory (roots) "Find the lock directory." + (defvar configure-lock-directory) (paths-find-site-directory roots "lock" "EMACSLOCKDIR" configure-lock-directory)) (defun paths-find-superlock-file (lock-directory) "Find the superlock file." + ;; #### There is no such variable configure-superlock-file! (cond ((null lock-directory) nil) diff -r 76b7d63099ad -r 8626e4521993 lisp/shadow.el --- a/lisp/shadow.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/shadow.el Mon Aug 13 11:07:10 2007 +0200 @@ -51,7 +51,7 @@ ;; Thanks to Francesco Potorti` for suggestions, ;; rewritings & speedups. -;; 1998-08-15 Martin Buchholz: Speed up using hashtables instead of lists. +;; 1998-08-15 Martin Buchholz: Speed up using hash tables instead of lists. ;;; Code: @@ -70,12 +70,12 @@ dir ; The dir being currently scanned. curr-files ; This dir's Emacs Lisp files. orig-dir ; Where the file was first seen. - (file-dirs - (make-hashtable 2000 'equal)) ; File names ever seen, with dirs. - (true-names - (make-hashtable 50 'equal)) ; Dirs ever considered. - (files-seen-this-dir - (make-hashtable 100 'equal)) ; Files seen so far in this dir. + (file-dirs ; File names ever seen, with dirs. + (make-hash-table :size 2000 :test 'equal)) + (true-names ; Dirs ever considered. + (make-hash-table :size 50 :test 'equal)) + (files-seen-this-dir ; Files seen so far in this dir. + (make-hash-table :size 100 :test 'equal)) ) (dolist (path-elt (or path load-path)) diff -r 76b7d63099ad -r 8626e4521993 lisp/simple.el --- a/lisp/simple.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/simple.el Mon Aug 13 11:07:10 2007 +0200 @@ -433,7 +433,7 @@ (and overwrite-mode (not (eolp)) (save-excursion (insert-char ?\ arg)))) -(defcustom delete-key-deletes-forward nil +(defcustom delete-key-deletes-forward t "*If non-nil, the DEL key will erase one character forwards. If nil, the DEL key will erase one character backwards." :type 'boolean @@ -2369,7 +2369,7 @@ (defun kill-comment (arg) "Kill the comment on this line, if any. With argument, kill comments on that many lines starting with this one." - ;; this function loses in a lot of situations. it incorrectly recognises + ;; this function loses in a lot of situations. it incorrectly recognizes ;; comment delimiters sometimes (ergo, inside a string), doesn't work ;; with multi-line comments, can kill extra whitespace if comment wasn't ;; through end-of-line, et cetera. diff -r 76b7d63099ad -r 8626e4521993 lisp/startup.el --- a/lisp/startup.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/startup.el Mon Aug 13 11:07:10 2007 +0200 @@ -364,13 +364,12 @@ (message "Back to top level.") (setq command-line-processed t) ;; Canonicalize HOME (PWD is canonicalized by init_buffer in buffer.c) - (unless (eq system-type 'vax-vms) - (let ((value (user-home-directory))) - (if (and value - (< (length value) (length default-directory)) - (equal (file-attributes default-directory) - (file-attributes value))) - (setq default-directory (file-name-as-directory value))))) + (let ((value (user-home-directory))) + (if (and value + (< (length value) (length default-directory)) + (equal (file-attributes default-directory) + (file-attributes value))) + (setq default-directory (file-name-as-directory value)))) (setq default-directory (abbreviate-file-name default-directory)) (initialize-xemacs-paths) diff -r 76b7d63099ad -r 8626e4521993 lisp/subr.el --- a/lisp/subr.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/subr.el Mon Aug 13 11:07:10 2007 +0200 @@ -88,9 +88,6 @@ ;; XEmacs: not used. ;; XEmacs: -(define-function 'not 'null) -(define-function-when-void 'numberp 'integerp) ; different when floats - (defun local-variable-if-set-p (sym buffer) "Return t if SYM would be local to BUFFER after it is set. A nil value for BUFFER is *not* the same as (current-buffer), but @@ -586,12 +583,14 @@ (cons (cons name defs) abbrev-table-name-list))))))) -(defun functionp (object) - "Non-nil if OBJECT can be called as a function." - (or (and (symbolp object) (fboundp object)) - (subrp object) - (compiled-function-p object) - (eq (car-safe object) 'lambda))) +;;; `functionp' has been moved into C. + +;;(defun functionp (object) +;; "Non-nil if OBJECT can be called as a function." +;; (or (and (symbolp object) (fboundp object)) +;; (subrp object) +;; (compiled-function-p object) +;; (eq (car-safe object) 'lambda))) diff -r 76b7d63099ad -r 8626e4521993 lisp/symbol-syntax.el --- a/lisp/symbol-syntax.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/symbol-syntax.el Mon Aug 13 11:07:10 2007 +0200 @@ -101,14 +101,12 @@ ;; ?_) (defun show-chars-with-syntax (tables syntax) - (let ((osyn (syntax-table)) - (schars nil)) + (let ((schars nil)) (unwind-protect (while (consp tables) (let* ((chars nil) (table-symbol (car tables)) - (table table-symbol) - (i 0)) + (table table-symbol)) (or (symbolp table-symbol) (error "bad argument non-symbol")) (while (symbolp table) diff -r 76b7d63099ad -r 8626e4521993 lisp/syntax.el --- a/lisp/syntax.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/syntax.el Mon Aug 13 11:07:10 2007 +0200 @@ -183,7 +183,7 @@ b means C is comment starter or comment ender for comment style b." (interactive ;; I really don't know why this is interactive - ;; help-form should at least be made useful whilst reading the second arg + ;; help-form should at least be made useful while reading the second arg "cSet syntax for character: \nsSet syntax for %c to: ") (cond ((syntax-table-p table)) ((not table) diff -r 76b7d63099ad -r 8626e4521993 lisp/term/internal.el --- a/lisp/term/internal.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/term/internal.el Mon Aug 13 11:07:10 2007 +0200 @@ -26,7 +26,7 @@ ;; --------------------------------------------------------------------------- ;; keyboard setup -- that's simple! (set-input-mode nil nil 0) -(define-key function-key-map [backspace] "\177") ; Normal behaviour for BS +(define-key function-key-map [backspace] "\177") ; Normal behavior for BS (define-key function-key-map [delete] "\C-d") ; ... and Delete (define-key function-key-map [tab] [?\t]) (define-key function-key-map [linefeed] [?\n]) diff -r 76b7d63099ad -r 8626e4521993 lisp/term/sun-mouse.el --- a/lisp/term/sun-mouse.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/term/sun-mouse.el Mon Aug 13 11:07:10 2007 +0200 @@ -137,46 +137,46 @@ ;;; All the useful code bits (defmacro sm::hit-code (hit) - (` (nth 0 (, hit)))) + `(nth 0 ,hit)) ;;; The button, or buttons if a chord. (defmacro sm::hit-button (hit) - (` (logand sm::ButtonBits (nth 0 (, hit))))) + `(logand sm::ButtonBits (nth 0 ,hit))) ;;; The shift, control, and meta flags. (defmacro sm::hit-shiftmask (hit) - (` (logand sm::ShiftmaskBits (nth 0 (, hit))))) + `(logand sm::ShiftmaskBits (nth 0 ,hit))) ;;; Set if a double click (but not a chord). (defmacro sm::hit-double (hit) - (` (logand sm::DoubleBits (nth 0 (, hit))))) + `(logand sm::DoubleBits (nth 0 ,hit))) ;;; Set on button release (as opposed to button press). (defmacro sm::hit-up (hit) - (` (logand sm::UpBits (nth 0 (, hit))))) + `(logand sm::UpBits (nth 0 ,hit))) ;;; Screen x position. -(defmacro sm::hit-x (hit) (list 'nth 1 hit)) +(defmacro sm::hit-x (hit) `(nth 1 ,hit)) ;;; Screen y position. -(defmacro sm::hit-y (hit) (list 'nth 2 hit)) +(defmacro sm::hit-y (hit) `(nth 2 ,hit)) ;;; Milliseconds since last hit. -(defmacro sm::hit-delta (hit) (list 'nth 3 hit)) +(defmacro sm::hit-delta (hit) `(nth 3 ,hit)) (defmacro sm::hit-up-p (hit) ; A predicate. - (` (not (zerop (sm::hit-up (, hit)))))) + `(not (zerop (sm::hit-up ,hit)))) ;;; ;;; Loc accessors. for sm::window-xy ;;; -(defmacro sm::loc-w (loc) (list 'nth 0 loc)) -(defmacro sm::loc-x (loc) (list 'nth 1 loc)) -(defmacro sm::loc-y (loc) (list 'nth 2 loc)) +(defmacro sm::loc-w (loc) `(nth 0 ,loc)) +(defmacro sm::loc-x (loc) `(nth 1 ,loc)) +(defmacro sm::loc-y (loc) `(nth 2 ,loc)) ;;; this is used extensively by sun-fns.el ;;; (defmacro eval-in-window (window &rest forms) "Switch to WINDOW, evaluate FORMS, return to original window." - (` (let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (progn - (select-window (, window)) - (,@ forms)) - (select-window OriginallySelectedWindow))))) + `(let ((OriginallySelectedWindow (selected-window))) + (unwind-protect + (progn + (select-window ,window) + ,@forms) + (select-window OriginallySelectedWindow)))) (put 'eval-in-window 'lisp-indent-function 1) ;;; @@ -188,14 +188,14 @@ "Switches to each window and evaluates FORM. Optional argument YESMINI says to include the minibuffer as a window. This is a macro, and does not evaluate its arguments." - (` (let ((OriginallySelectedWindow (selected-window))) - (unwind-protect - (while (progn - (, form) - (not (eq OriginallySelectedWindow - (select-window - (next-window nil (, yesmini))))))) - (select-window OriginallySelectedWindow))))) + `(let ((OriginallySelectedWindow (selected-window))) + (unwind-protect + (while (progn + ,form + (not (eq OriginallySelectedWindow + (select-window + (next-window nil ,yesmini)))))) + (select-window OriginallySelectedWindow)))) (put 'eval-in-window 'lisp-indent-function 0) (defun move-to-loc (x y) diff -r 76b7d63099ad -r 8626e4521993 lisp/term/sun.el --- a/lisp/term/sun.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/term/sun.el Mon Aug 13 11:07:10 2007 +0200 @@ -217,14 +217,14 @@ (define-key suntool-map "jl" 'kill-region-and-unmark) ; Delete (define-key suntool-map "j\M-l" 'exchange-point-and-mark); M-Delete (define-key suntool-map "j," - '(lambda () (interactive) (pop-mark 1))) ; C-Delete + #'(lambda () (interactive) (pop-mark 1))) ; C-Delete (define-key suntool-map "fT" 'shrink-window-horizontally) ; T6 (define-key suntool-map "gT" 'enlarge-window-horizontally) ; T7 (define-key suntool-map "ft" 'shrink-window) ; t6 (define-key suntool-map "gt" 'enlarge-window) ; t7 -(define-key suntool-map "cT" '(lambda(n) (interactive "p") (scroll-down n))) -(define-key suntool-map "dT" '(lambda(n) (interactive "p") (scroll-up n))) +(define-key suntool-map "cT" #'(lambda(n) (interactive "p") (scroll-down n))) +(define-key suntool-map "dT" #'(lambda(n) (interactive "p") (scroll-up n))) (define-key suntool-map "ct" 'scroll-down-in-place) ; t3 (define-key suntool-map "dt" 'scroll-up-in-place) ; t4 (define-key ctl-x-map "*" suntool-map) diff -r 76b7d63099ad -r 8626e4521993 lisp/toolbar-items.el --- a/lisp/toolbar-items.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/toolbar-items.el Mon Aug 13 11:07:10 2007 +0200 @@ -33,7 +33,7 @@ ;; is compiled in). ;; Miscellaneous toolbar functions, useful for users to redefine, in -;; order to get different behaviour. +;; order to get different behavior. ;;; Code: diff -r 76b7d63099ad -r 8626e4521993 lisp/toolbar.el --- a/lisp/toolbar.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/toolbar.el Mon Aug 13 11:07:10 2007 +0200 @@ -36,9 +36,9 @@ customized through the options menu." :group 'display :type 'boolean - :set '(lambda (var val) - (set-specifier default-toolbar-visible-p val) - (setq toolbar-visible-p val)) + :set #'(lambda (var val) + (set-specifier default-toolbar-visible-p val) + (setq toolbar-visible-p val)) ) (defcustom toolbar-captioned-p ;; added for the options menu - dverna apr. 98 @@ -47,9 +47,9 @@ customized through the options menu." :group 'display :type 'boolean - :set '(lambda (var val) - (set-specifier toolbar-buttons-captioned-p val) - (setq toolbar-captioned-p val)) + :set #'(lambda (var val) + (set-specifier toolbar-buttons-captioned-p val) + (setq toolbar-captioned-p val)) ) (defcustom default-toolbar-position ;; added for the options menu - dverna @@ -61,9 +61,9 @@ (const :tag "bottom" 'bottom) (const :tag "left" 'left) (const :tag "right" 'right)) - :set '(lambda (var val) - (set-default-toolbar-position val) - (setq default-toolbar-position val)) + :set #'(lambda (var val) + (set-default-toolbar-position val) + (setq default-toolbar-position val)) ) (defvar toolbar-help-enabled t diff -r 76b7d63099ad -r 8626e4521993 lisp/version.el --- a/lisp/version.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/version.el Mon Aug 13 11:07:10 2007 +0200 @@ -125,7 +125,7 @@ ;; `what(1)' can extract from the executable or a core file. We don't ;; actually need this to be pointed to from lisp; pure objects can't ;; be GCed. -(or (memq system-type '(vax-vms windows-nt ms-dos)) +(or (memq system-type '(windows-nt ms-dos)) (purecopy (concat "\n@" "(#)" (emacs-version) "\n@" "(#)" "Configuration: " system-configuration "\n"))) diff -r 76b7d63099ad -r 8626e4521993 lisp/very-early-lisp.el --- a/lisp/very-early-lisp.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/very-early-lisp.el Mon Aug 13 11:07:10 2007 +0200 @@ -32,8 +32,6 @@ ;;; Code: -(define-function 'defalias 'define-function) - ;;; Macros from Michael Sperber to replace read-time Lisp reader macros #-, #+ ;;; ####fixme duplicated in make-docfile.el and update-elc.el (defmacro assemble-list (&rest components) diff -r 76b7d63099ad -r 8626e4521993 lisp/view-less.el --- a/lisp/view-less.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/view-less.el Mon Aug 13 11:07:10 2007 +0200 @@ -148,6 +148,7 @@ "\\\\[scroll-up] = page forward; \\[scroll-down] = page back; \ \\[view-mode-describe] = help; \\[view-quit] = quit."))) +(defvar view-major-mode) (defvar view-exit-position) (defvar view-prev-buffer) (defvar view-exit-action) diff -r 76b7d63099ad -r 8626e4521993 lisp/wid-edit.el --- a/lisp/wid-edit.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/wid-edit.el Mon Aug 13 11:07:10 2007 +0200 @@ -533,7 +533,7 @@ widget-shadow-subrs) (defun widget-put (widget property value) "In WIDGET set PROPERTY to VALUE. -The value can later be retrived with `widget-get'." +The value can later be retrieved with `widget-get'." (setcdr widget (plist-put (cdr widget) property value)))) ;; Recoded in C, for efficiency: @@ -730,7 +730,7 @@ ;; format. (when (valid-image-instantiator-format-p (caar formats)) (setq file (locate-file image dirlist - (mapconcat 'identity (cdar formats) + (mapconcat #'identity (cdar formats) ":")))) (unless file (pop formats))) @@ -1129,7 +1129,7 @@ (error "This widget is inactive")) (let ((current-glyph 'down)) ;; We always know what glyph is drawn currently, to avoid - ;; unnecessary extent changes. Is this any noticable gain? + ;; unnecessary extent changes. Is this any noticeable gain? (unwind-protect (progn ;; Press the glyph. diff -r 76b7d63099ad -r 8626e4521993 lisp/widget.el --- a/lisp/widget.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/widget.el Mon Aug 13 11:07:10 2007 +0200 @@ -42,13 +42,12 @@ (defmacro define-widget-keywords (&rest keys) "This doesn't do anything in Emacs 20 or XEmacs." - (` - (eval-and-compile - (let ((keywords (quote (, keys)))) - (while keywords - (or (boundp (car keywords)) - (set (car keywords) (car keywords))) - (setq keywords (cdr keywords))))))) + `(eval-and-compile + (let ((keywords (quote ,keys))) + (while keywords + (or (boundp (car keywords)) + (set (car keywords) (car keywords))) + (setq keywords (cdr keywords)))))) (defun define-widget (name class doc &rest args) "Define a new widget type named NAME from CLASS. diff -r 76b7d63099ad -r 8626e4521993 lisp/winnt.el --- a/lisp/winnt.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/winnt.el Mon Aug 13 11:07:10 2007 +0200 @@ -76,7 +76,7 @@ See also `auto-save-file-name-p'." (let ((name (original-make-auto-save-file-name)) (start 0)) - ;; destructively replace occurences of * or ? with $ + ;; destructively replace occurrences of * or ? with $ (while (string-match "[?*]" name start) (aset name (match-beginning 0) ?$) (setq start (1+ (match-end 0)))) @@ -88,7 +88,7 @@ (defun nt-quote-args-verbatim (args) "Copy ARG list verbatim, separating each arg with space." - (mapconcat 'identity args " ")) + (mapconcat #'identity args " ")) (defun nt-quote-args-prefix-quote (prefix args) (mapconcat (lambda (str) diff -r 76b7d63099ad -r 8626e4521993 lisp/x-compose.el --- a/lisp/x-compose.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/x-compose.el Mon Aug 13 11:07:10 2007 +0200 @@ -104,24 +104,22 @@ (require 'x-iso8859-1) -(defun make-compose-map (map-sym) - (let ((map (make-sparse-keymap))) - (set map-sym map) - (set-keymap-name map map-sym) - ;; Required to tell XEmacs the keymaps were actually autoloaded. - ;; #### Make this unnecessary! - (fset map-sym map))) +(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)))) -(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) + (define-compose-map compose-map) + (define-compose-map compose-acute-map) + (define-compose-map compose-grave-map) + (define-compose-map compose-cedilla-map) + (define-compose-map compose-diaeresis-map) + (define-compose-map compose-circumflex-map) + (define-compose-map compose-tilde-map) + (define-compose-map compose-ring-map)) (define-key compose-map 'acute compose-acute-map) (define-key compose-map 'grave compose-grave-map) @@ -131,28 +129,8 @@ (define-key compose-map 'tilde compose-tilde-map) (define-key compose-map 'degree compose-ring-map) -;;(eval-when-compile -;; (defsubst define-dead-key-map (key map) -;; (define-key function-key-map key map) -;; (define-key compose-map key map))) - -;;;###utoload (autoload 'compose-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-acute-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-grave-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-cedilla-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-diaeresis-map "x-compose" nil t 'keymap) -;;;###utoload (autoload 'compose-degree-map "x-compose" nil t 'keymap) -;;;###utoload (define-key function-key-map [acute] 'compose-acute-map) -;;;###utoload (define-key function-key-map [grave] 'compose-grave-map) -;;;###utoload (define-key function-key-map [cedilla] 'compose-cedilla-map) -;;;###utoload (define-key function-key-map [diaeresis] 'compose-diaeresis-map) -;;;###utoload (define-key function-key-map [degree] 'compose-degree-map) -;;;###utoload (define-key function-key-map [multi-key] 'compose-map) -;;;###utoload (define-key global-map [multi-key] 'compose-map) - ;;(define-key function-key-map [multi-key] compose-map) - ;; The following is necessary, because one can't rebind [degree] ;; and use it to insert the degree sign! ;;(defun compose-insert-degree () @@ -160,13 +138,6 @@ ;; (interactive) ;; (insert ?\260)) -;; The "Dead" keys: -;; -;;(define-dead-key-map [acute] compose-acute-map) -;;(define-dead-key-map [cedilla] compose-cedilla-map) -;;(define-dead-key-map [diaeresis] compose-diaeresis-map) -;;(define-dead-key-map [degree] compose-ring-map) - (define-key compose-map [acute] compose-acute-map) (define-key compose-map [?'] compose-acute-map) (define-key compose-map [grave] compose-grave-map) @@ -183,116 +154,6 @@ (define-key compose-map [?*] compose-ring-map) -;;; The dead keys might really be called just about anything, depending -;;; on the vendor. MIT thinks that the prefixes are "SunFA_", "D", and -;;; "hpmute_" for Sun, DEC, and HP respectively. However, OpenWindows 3 -;;; thinks that the prefixes are "SunXK_FA_", "DXK_", and "hpXK_mute_". -;;; And HP (who don't mention Sun and DEC at all) use "XK_mute_". -;;; Go figure. - -;;; Presumably if someone is running OpenWindows, they won't be using -;;; the DEC or HP keysyms, but if they are defined then that is possible, -;;; so in that case we accept them all. - -;;; If things seem not to be working, you might want to check your -;;; /usr/lib/X11/XKeysymDB file to see if your vendor has an equally -;;; mixed up view of what these keys should be called. - -;; Sun according to MIT: -;; - -;;(when (x-valid-keysym-name-p "SunFA_Acute") -;; (define-dead-key-map [SunFA_Acute] compose-acute-map) -;; (define-dead-key-map [SunFA_Grave] compose-grave-map) -;; (define-dead-key-map [SunFA_Cedilla] compose-cedilla-map) -;; (define-dead-key-map [SunFA_Diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [SunFA_Circum] compose-circumflex-map) -;; (define-dead-key-map [SunFA_Tilde] compose-tilde-map) -;; ) -;; -;;;; Sun according to OpenWindows 2: -;;;; -;;(when (x-valid-keysym-name-p "Dead_Grave") -;; (define-dead-key-map [Dead_Grave] compose-grave-map) -;; (define-dead-key-map [Dead_Circum] compose-circumflex-map) -;; (define-dead-key-map [Dead_Tilde] compose-tilde-map) -;; ) -;; -;;;; Sun according to OpenWindows 3: -;;;; -;;(when (x-valid-keysym-name-p "SunXK_FA_Acute") -;; (define-dead-key-map [SunXK_FA_Acute] compose-acute-map) -;; (define-dead-key-map [SunXK_FA_Grave] compose-grave-map) -;; (define-dead-key-map [SunXK_FA_Cedilla] compose-cedilla-map) -;; (define-dead-key-map [SunXK_FA_Diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [SunXK_FA_Circum] compose-circumflex-map) -;; (define-dead-key-map [SunXK_FA_Tilde] compose-tilde-map) -;; ) -;; -;;;; DEC according to MIT: -;;;; -;;(when (x-valid-keysym-name-p "Dacute_accent") -;; (define-dead-key-map [Dacute_accent] compose-acute-map) -;; (define-dead-key-map [Dgrave_accent] compose-grave-map) -;; (define-dead-key-map [Dcedilla_accent] compose-cedilla-map) -;; (define-dead-key-map [Dcircumflex_accent] compose-circumflex-map) -;; (define-dead-key-map [Dtilde] compose-tilde-map) -;; (define-dead-key-map [Dring_accent] compose-ring-map) -;; ) -;; -;;;; DEC according to OpenWindows 3: -;;;; -;;(when (x-valid-keysym-name-p "DXK_acute_accent") -;; (define-dead-key-map [DXK_acute_accent] compose-acute-map) -;; (define-dead-key-map [DXK_grave_accent] compose-grave-map) -;; (define-dead-key-map [DXK_cedilla_accent] compose-cedilla-map) -;; (define-dead-key-map [DXK_circumflex_accent] compose-circumflex-map) -;; (define-dead-key-map [DXK_tilde] compose-tilde-map) -;; (define-dead-key-map [DXK_ring_accent] compose-ring-map) -;; ) -;; -;;;; HP according to MIT: -;;;; -;;(when (x-valid-keysym-name-p "hpmute_acute") -;; (define-dead-key-map [hpmute_acute] compose-acute-map) -;; (define-dead-key-map [hpmute_grave] compose-grave-map) -;; (define-dead-key-map [hpmute_diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [hpmute_asciicircum] compose-circumflex-map) -;; (define-dead-key-map [hpmute_asciitilde] compose-tilde-map) -;; ) -;; -;;;; HP according to OpenWindows 3: -;;;; -;;(when (x-valid-keysym-name-p "hpXK_mute_acute") -;; (define-dead-key-map [hpXK_mute_acute] compose-acute-map) -;; (define-dead-key-map [hpXK_mute_grave] compose-grave-map) -;; (define-dead-key-map [hpXK_mute_diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [hpXK_mute_asciicircum] compose-circumflex-map) -;; (define-dead-key-map [hpXK_mute_asciitilde] compose-tilde-map) -;; ) -;; -;;;; HP according to HP-UX 8.0: -;;;; -;;(when (x-valid-keysym-name-p "XK_mute_acute") -;; (define-dead-key-map [XK_mute_acute] compose-acute-map) -;; (define-dead-key-map [XK_mute_grave] compose-grave-map) -;; (define-dead-key-map [XK_mute_diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [XK_mute_asciicircum] compose-circumflex-map) -;; (define-dead-key-map [XK_mute_asciitilde] compose-tilde-map) -;; ) -;; -;;;; Xfree seems to use lower case and a hyphen -;;(when (x-valid-keysym-name-p "dead-tilde") -;; (define-dead-key-map [dead-acute] compose-acute-map) -;; (define-dead-key-map [dead-grave] compose-grave-map) -;; (define-dead-key-map [dead-cedilla] compose-cedilla-map) -;; (define-dead-key-map [dead-diaeresis] compose-diaeresis-map) -;; (define-dead-key-map [dead-circum] compose-circumflex-map) -;; (define-dead-key-map [dead-tilde] compose-tilde-map) -;; ) - - - ;;; The contents of the "dead key" maps. These are shared by the ;;; compose-map. diff -r 76b7d63099ad -r 8626e4521993 lisp/x-init.el --- a/lisp/x-init.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/x-init.el Mon Aug 13 11:07:10 2007 +0200 @@ -101,7 +101,7 @@ (define-key function-key-map [,key] ',map)))) (defun x-initialize-compose () - "Enable compose processing" + "Enable compose key and dead key processing." (autoload 'compose-map "x-compose" nil t 'keymap) (autoload 'compose-acute-map "x-compose" nil t 'keymap) (autoload 'compose-grave-map "x-compose" nil t 'keymap) @@ -212,6 +212,10 @@ (x-define-dead-key dead-tilde compose-tilde-map) ) +(eval-when-compile + (load "x-win-sun" nil t) + (load "x-win-xfree86" nil t)) + (defun x-initialize-keyboard () "Perform X-Server-specific initializations. Don't call this." ;; This is some heuristic junk that tries to guess whether this is @@ -222,47 +226,38 @@ ;; remotely like a Sun - check for the Find key on a particular ;; keycode, for example. It'd be nice to have a table of this to ;; recognize various keyboards; see also xkeycaps. + ;; + ;; Note that we cannot use most vendor-provided proprietary keyboard + ;; APIs to identify the keyboard - those only work on the console. + ;; xkeycaps has the same problem when running `remotely'. (let ((vendor (x-server-vendor))) (cond ((or (string-match "Sun Microsystems" vendor) ;; MIT losingly fails to tell us what hardware the X server ;; is managing, so assume all MIT displays are Suns... HA HA! (string-equal "MIT X Consortium" vendor) (string-equal "X Consortium" vendor)) - ;; Ok, we think this could be a Sun keyboard. Load the Sun code. - ;; (load "x-win-sun")) + ;; Ok, we think this could be a Sun keyboard. Run the Sun code. (x-win-init-sun)) ((string-match "XFree86" vendor) ;; Those XFree86 people do some weird keysym stuff, too. - ;; (load "x-win-xfree86"))))) (x-win-init-xfree86))))) ;; Moved from x-toolbar.el, since InfoDock doesn't dump a x-toolbar.el. (defun x-init-toolbar-from-resources (locale) - (x-init-specifier-from-resources - top-toolbar-height 'natnum locale - '("topToolBarHeight" . "TopToolBarHeight")) - (x-init-specifier-from-resources - bottom-toolbar-height 'natnum locale - '("bottomToolBarHeight" . "BottomToolBarHeight")) - (x-init-specifier-from-resources - left-toolbar-width 'natnum locale - '("leftToolBarWidth" . "LeftToolBarWidth")) - (x-init-specifier-from-resources - right-toolbar-width 'natnum locale - '("rightToolBarWidth" . "RightToolBarWidth")) - (x-init-specifier-from-resources - top-toolbar-border-width 'natnum locale - '("topToolBarBorderWidth" . "TopToolBarBorderWidth")) - (x-init-specifier-from-resources - bottom-toolbar-border-width 'natnum locale - '("bottomToolBarBorderWidth" . "BottomToolBarBorderWidth")) - (x-init-specifier-from-resources - left-toolbar-border-width 'natnum locale - '("leftToolBarBorderWidth" . "LeftToolBarBorderWidth")) - (x-init-specifier-from-resources - right-toolbar-border-width 'natnum locale - '("rightToolBarBorderWidth" . "RightToolBarBorderWidth"))) + (loop for (specifier . resname) in + `(( ,top-toolbar-height . "topToolBarHeight") + (,bottom-toolbar-height . "bottomToolBarHeight") + ( ,left-toolbar-width . "leftToolBarWidth") + ( ,right-toolbar-width . "rightToolBarWidth") + + ( ,top-toolbar-border-width . "topToolBarBorderWidth") + (,bottom-toolbar-border-width . "bottomToolBarBorderWidth") + ( ,left-toolbar-border-width . "leftToolBarBorderWidth") + ( ,right-toolbar-border-width . "rightToolBarBorderWidth")) + do + (x-init-specifier-from-resources + specifier 'natnum locale (cons resname (upcase-initials resname))))) (defvar pre-x-win-initted nil) @@ -282,6 +277,7 @@ (defun init-x-win () "Initialize X Windows at startup. Don't call this." (when (not x-win-initted) + (defvar x-app-defaults-directory) (init-pre-x-win) ;; Open the X display when this file is loaded @@ -314,16 +310,16 @@ ;; these are only ever called if zmacs-regions is true. (add-hook 'zmacs-deactivate-region-hook (lambda () - (if (console-on-window-system-p) - (x-disown-selection)))) + (when (console-on-window-system-p) + (x-disown-selection)))) (add-hook 'zmacs-activate-region-hook (lambda () - (if (console-on-window-system-p) - (x-activate-region-as-selection)))) + (when (console-on-window-system-p) + (x-activate-region-as-selection)))) (add-hook 'zmacs-update-region-hook (lambda () - (if (console-on-window-system-p) - (x-activate-region-as-selection)))) + (when (console-on-window-system-p) + (x-activate-region-as-selection)))) ;; Motif-ish bindings ;; The following two were generally unliked. ;;(define-key global-map '(shift delete) 'kill-primary-selection) diff -r 76b7d63099ad -r 8626e4521993 lisp/x-iso8859-1.el --- a/lisp/x-iso8859-1.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/x-iso8859-1.el Mon Aug 13 11:07:10 2007 +0200 @@ -44,7 +44,7 @@ ;; keys are bound to one-character keyboard macros, so that `kp-9' will, by ;; default, do the same thing that `9' does, in whatever the current mode is. -;; The standard case and syntax tables are set in prim/iso8859-1.el, since +;; The standard case and syntax tables are set in iso8859-1.el, since ;; that is not X-specific. ;;; Code: @@ -71,16 +71,16 @@ ;; the keysym symbols. ;; (mapcar '(lambda (sym-and-code) - (list 'put (list 'quote (car sym-and-code)) - ''x-iso8859/1 (car (cdr sym-and-code)))) + (list 'put (list 'quote (car sym-and-code)) + ''x-iso8859/1 (car (cdr sym-and-code)))) syms-and-iso8859/1-codes) ;; ;; Then emit code that binds all of those keysym symbols to ;; `self-insert-command'. ;; (mapcar '(lambda (sym-and-code) - (list 'global-set-key (list 'quote (car sym-and-code)) - ''self-insert-command)) + (list 'global-set-key (list 'quote (car sym-and-code)) + ''self-insert-command)) syms-and-iso8859/1-codes) ;; ;; Then emit the value of iso8859/1-code-to-x-keysym-table. @@ -96,8 +96,8 @@ '((8 backspace) (9 tab) (10 linefeed) (13 return) (27 escape) (32 space) (127 delete))) (mapcar '(lambda (sym-and-code) - (or (aref v (car (cdr sym-and-code))) - (aset v (car (cdr sym-and-code)) (car sym-and-code)))) + (or (aref v (car (cdr sym-and-code))) + (aset v (car (cdr sym-and-code)) (car sym-and-code)))) syms-and-iso8859/1-codes) (list (list 'setq 'iso8859/1-code-to-x-keysym-table v))) )))) @@ -211,8 +211,8 @@ ((macro . (lambda (&rest syms-and-iso8859/1-codes) (cons 'progn (mapcar '(lambda (sym-and-code) - (list 'put (list 'quote (car sym-and-code)) - ''x-iso8859/1 (car (cdr sym-and-code)))) + (list 'put (list 'quote (car sym-and-code)) + ''x-iso8859/1 (car (cdr sym-and-code)))) syms-and-iso8859/1-codes)))) ;; ;; Let's do the appropriate thing for some vendor-specific keysyms too... diff -r 76b7d63099ad -r 8626e4521993 lisp/x-mouse.el --- a/lisp/x-mouse.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/x-mouse.el Mon Aug 13 11:07:10 2007 +0200 @@ -119,7 +119,7 @@ (set-buffer (extent-object (car primary-selection-extent))) (x-store-cutbuffer (mapconcat - 'identity + #'identity (extract-rectangle (extent-start-position (car primary-selection-extent)) (extent-end-position (car (reverse primary-selection-extent)))) diff -r 76b7d63099ad -r 8626e4521993 lisp/x-win-sun.el --- a/lisp/x-win-sun.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/x-win-sun.el Mon Aug 13 11:07:10 2007 +0200 @@ -64,19 +64,9 @@ ;;; Code: +;;;###autoload (defun x-win-init-sun () - (defun x-remap-keysyms-using-function-key-map (from-key to-key) - (dolist (prefix '(() (shift) (control) (meta) (alt) - (shift control) (shift alt) (shift meta) - (control alt) (control meta) (alt meta) - (shift control alt) (shift control meta) - (shift alt meta) (control alt meta) - (shift control alt meta))) - (define-key function-key-map - (append prefix (list from-key)) - (vector (append prefix (list to-key)))))) - ;; help is ok ;; num_lock is ok ;; up is ok @@ -164,9 +154,15 @@ (f12 again)))) ) do (when (x-keysym-on-keyboard-sans-modifiers-p from-key) - (x-remap-keysyms-using-function-key-map from-key to-key))) - - (unintern 'x-remap-keysyms-using-function-key-map) + (dolist (prefix '(() (shift) (control) (meta) (alt) + (shift control) (shift alt) (shift meta) + (control alt) (control meta) (alt meta) + (shift control alt) (shift control meta) + (shift alt meta) (control alt meta) + (shift control alt meta))) + (define-key function-key-map + (append prefix (list from-key)) + (vector (append prefix (list to-key))))))) ;; for each element in the left column of the above table, alias it ;; to the thing in the right column. Then do the same for many, but diff -r 76b7d63099ad -r 8626e4521993 lisp/x-win-xfree86.el --- a/lisp/x-win-xfree86.el Mon Aug 13 11:06:08 2007 +0200 +++ b/lisp/x-win-xfree86.el Mon Aug 13 11:07:10 2007 +0200 @@ -39,6 +39,7 @@ ;; For no obvious reason, shift-F1 is called F13, although Meta-F1 and ;; Control-F1 have normal names. +;;;###autoload (defun x-win-init-xfree86 () (loop for (key sane-key) in '((f13 f1) diff -r 76b7d63099ad -r 8626e4521993 lwlib/Makefile.in.in --- a/lwlib/Makefile.in.in Mon Aug 13 11:06:08 2007 +0200 +++ b/lwlib/Makefile.in.in Mon Aug 13 11:07:10 2007 +0200 @@ -32,7 +32,7 @@ RM = rm -f AR = ar cq -CC=@CC@ +CC=@XEMACS_CC@ CPP=@CPP@ CFLAGS=@CFLAGS@ CPPFLAGS=@CPPFLAGS@ diff -r 76b7d63099ad -r 8626e4521993 lwlib/xlwmenu.c --- a/lwlib/xlwmenu.c Mon Aug 13 11:06:08 2007 +0200 +++ b/lwlib/xlwmenu.c Mon Aug 13 11:07:10 2007 +0200 @@ -83,23 +83,23 @@ /* We must use an iso8859-1 font here, or people without $LANG set lose. It's fair to assume that those who do have $LANG set also have the *fontList resource set, or at least know how to deal with this. */ - XtRString, "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-1"}, + XtRString, (XtPointer) "-*-helvetica-bold-r-*-*-*-120-*-*-*-*-iso8859-1"}, #else {XtNfont, XtCFont, XtRFontStruct, sizeof(XFontStruct *), - offset(menu.font), XtRString, "XtDefaultFont"}, + offset(menu.font), XtRString, (XtPointer) "XtDefaultFont"}, # ifdef USE_XFONTSET {XtNfontSet, XtCFontSet, XtRFontSet, sizeof(XFontSet), - offset(menu.font_set), XtRString, "XtDefaultFontSet"}, + offset(menu.font_set), XtRString, (XtPointer) "XtDefaultFontSet"}, # endif #endif {XtNforeground, XtCForeground, XtRPixel, sizeof(Pixel), - offset(menu.foreground), XtRString, "XtDefaultForeground"}, + offset(menu.foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNbuttonForeground, XtCButtonForeground, XtRPixel, sizeof(Pixel), - offset(menu.button_foreground), XtRString, "XtDefaultForeground"}, + offset(menu.button_foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNhighlightForeground, XtCHighlightForeground, XtRPixel, sizeof(Pixel), - offset(menu.highlight_foreground), XtRString, "XtDefaultForeground"}, + offset(menu.highlight_foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNtitleForeground, XtCTitleForeground, XtRPixel, sizeof(Pixel), - offset(menu.title_foreground), XtRString, "XtDefaultForeground"}, + offset(menu.title_foreground), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNmargin, XtCMargin, XtRDimension, sizeof(Dimension), offset(menu.margin), XtRImmediate, (XtPointer)2}, {XmNmarginWidth, XmCMarginWidth, XmRHorizontalDimension, sizeof(Dimension), @@ -867,16 +867,16 @@ #endif ) { -int i,s=0; -char *chars; + int i, s = 0; + char *chars; #ifdef NEED_MOTIF XmStringGetLtoR (string, XmFONTLIST_DEFAULT_TAG, &chars); #else chars = string; #endif - for (i=0;chars[i];++i) { - if (chars[i]=='%'&&chars[i+1]=='_') { + for (i=0; chars[i]; ++i) { + if (chars[i] == '%' && chars[i+1] == '_') { int w; x += string_draw_range (mw, window, x, y, gc, chars, s, i); @@ -1475,7 +1475,7 @@ print_widget_value (wv->next, 0, depth); } } -#endif +#endif /* SLOPPY_TYPES < 2 */ static Boolean all_dashes_p (char *s) @@ -1489,30 +1489,29 @@ 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; +#if SLOPPY_TYPES + 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 - { -#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; + return TEXT_TYPE; #else + else abort(); + return UNSPECIFIED_TYPE; /* Not reached */ #endif - } } static void diff -r 76b7d63099ad -r 8626e4521993 man/ChangeLog --- a/man/ChangeLog Mon Aug 13 11:06:08 2007 +0200 +++ b/man/ChangeLog Mon Aug 13 11:07:10 2007 +0200 @@ -1,3 +1,72 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + +1998-11-30 Martin Buchholz + + * xemacs/startup.texi (Startup Paths): + * xemacs/custom.texi (Widgets): + * xemacs-faq.texi (Q3.0.5): + * xemacs-faq.texi (Top): + + * widget.texi (info-link): + + * lispref/objects.texi (Type Predicates): + * lispref/objects.texi (Hash Table Type): + * lispref/objects.texi (Primitive Types): + * lispref/objects.texi (Lisp Data Types): + * lispref/macros.texi (Backquote): + * lispref/hash-tables.texi (Weak Hash Tables): + * lispref/hash-tables.texi: + * lispref/errors.texi (Standard Errors): + * lispref/compile.texi (Disassembly): + * lispref/compile.texi (Compiled-Function Objects): + * lispref/compile.texi (Eval During Compile): + * lispref/compile.texi (Docs and Compilation): + * lispref/compile.texi (Compilation Functions): + * lispref/compile.texi (Speed of Byte-Code): + * lispref/compile.texi (Byte Compilation): + * lispref/building.texi (Garbage Collection): + + * internals/internals.texi (Simple Special Forms): + * internals/internals.texi (Evaluation; Stack Frames; Bindings): + * internals/internals.texi (Specifics of the Event Gathering Mechanism): + * internals/internals.texi (String): + * internals/internals.texi (Introduction to Allocation): + * internals/internals.texi (Allocation of Objects in XEmacs Lisp): + * internals/internals.texi (Modules for Internationalization): + * internals/internals.texi (Modules for Interfacing with X Windows): + * internals/internals.texi (Modules for Interfacing with the Operating System): + * internals/internals.texi (Modules for Other Aspects of the Lisp Interpreter and Object System): + * internals/internals.texi (Modules for Interfacing with the File System): + * internals/internals.texi (Modules for the Redisplay Mechanism): + * internals/internals.texi (Modules for the Basic Displayable Lisp Objects): + * internals/internals.texi (Editor-Level Control Flow Modules): + * internals/internals.texi (Modules for Standard Editing Operations): + * internals/internals.texi (Basic Lisp Modules): + * internals/internals.texi (Low-Level Modules): + * internals/internals.texi (A Summary of the Various XEmacs Modules): + * internals/internals.texi (An Example of Mule-Aware Code): + * internals/internals.texi (Working With Character and Byte Positions): + * internals/internals.texi (Writing Lisp Primitives): + * internals/internals.texi (General Coding Rules): + * internals/internals.texi (How Lisp Objects Are Represented in C): + * internals/internals.texi (The XEmacs Object System (Abstractly Speaking)): + * internals/internals.texi (XEmacs From the Perspective of Building): + * internals/internals.texi (The Lisp Language): + * internals/internals.texi (Top): + * internals/internals.texi: + - rewrite Internals manual + + * cl.texi (Porting Common Lisp): + * cl.texi (Hash Tables): + * cl.texi (Association Lists): + * cl.texi (Declarations): + * cl.texi (For Clauses): + * cl.texi (Basic Setf): + * cl.texi (Equality Predicates): + - mega patch + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff -r 76b7d63099ad -r 8626e4521993 man/cl.texi --- a/man/cl.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/cl.texi Mon Aug 13 11:07:10 2007 +0200 @@ -947,13 +947,9 @@ objects are compared as if by @code{equal}. This function differs from Common Lisp @code{equalp} in several -respects. First, in keeping with the idea that strings are less +respects. In keeping with the idea that strings are less vector-like in Emacs Lisp, this package's @code{equalp} also will not -compare strings against vectors of integers. Second, Common Lisp's -@code{equalp} compares hash tables without regard to ordering, whereas -this package simply compares hash tables in terms of their underlying -structure (which means vectors for Lucid Emacs 19 hash tables, or lists -for other hash tables). +compare strings against vectors of integers. @end defun Also note that the Common Lisp functions @code{member} and @code{assoc} @@ -1098,44 +1094,44 @@ @item The following Emacs-specific functions are also @code{setf}-able. -(Some of these are defined only in Emacs 19 or only in Lucid Emacs.) +(Some of these are defined only in Emacs 19 or only in XEmacs.) @smallexample -buffer-file-name marker-position -buffer-modified-p match-data -buffer-name mouse-position -buffer-string overlay-end -buffer-substring overlay-get -current-buffer overlay-start -current-case-table point -current-column point-marker -current-global-map point-max -current-input-mode point-min -current-local-map process-buffer -current-window-configuration process-filter -default-file-modes process-sentinel -default-value read-mouse-position -documentation-property screen-height -extent-data screen-menubar -extent-end-position screen-width -extent-start-position selected-window -face-background selected-screen -face-background-pixmap selected-frame -face-font standard-case-table -face-foreground syntax-table -face-underline-p window-buffer -file-modes window-dedicated-p -frame-height window-display-table -frame-parameters window-height -frame-visible-p window-hscroll -frame-width window-point -get-register window-start -getenv window-width -global-key-binding x-get-cut-buffer -keymap-parent x-get-cutbuffer +buffer-file-name marker-position +buffer-modified-p match-data +buffer-name mouse-position +buffer-string overlay-end +buffer-substring overlay-get +current-buffer overlay-start +current-case-table point +current-column point-marker +current-global-map point-max +current-input-mode point-min +current-local-map process-buffer +current-window-configuration process-filter +default-file-modes process-sentinel +default-value read-mouse-position +documentation-property screen-height +extent-data screen-menubar +extent-end-position screen-width +extent-start-position selected-window +face-background selected-screen +face-background-pixmap selected-frame +face-font standard-case-table +face-foreground syntax-table +face-underline-p window-buffer +file-modes window-dedicated-p +frame-height window-display-table +frame-parameters window-height +frame-visible-p window-hscroll +frame-width window-point +get-register window-start +getenv window-width +global-key-binding x-get-cut-buffer +keymap-parent x-get-cutbuffer local-key-binding x-get-secondary-selection -mark x-get-selection -mark-marker +mark x-get-selection +mark-marker @end smallexample Most of these have directly corresponding ``set'' functions, like @@ -2584,14 +2580,14 @@ hash table entry. @item for @var{var} being the key-codes of @var{keymap} -This clause iterates over the entries in @var{keymap}. In GNU Emacs -18 and 19, keymaps are either alists or vectors, and key-codes are -integers or symbols. In Lucid Emacs 19, keymaps are a special new -data type, and key-codes are symbols or lists of symbols. The -iteration does not enter nested keymaps or inherited (parent) keymaps. -You can use @samp{the key-bindings} to access the commands bound to -the keys rather than the key codes, and you can add a @code{using} -clause to access both the codes and the bindings together. +This clause iterates over the entries in @var{keymap}. In GNU Emacs 18 +and 19, keymaps are either alists or vectors, and key-codes are integers +or symbols. In XEmacs, keymaps are a special new data type, and +key-codes are symbols or lists of symbols. The iteration does not enter +nested keymaps or inherited (parent) keymaps. You can use @samp{the +key-bindings} to access the commands bound to the keys rather than the +key codes, and you can add a @code{using} clause to access both the +codes and the bindings together. @item for @var{var} being the key-seqs of @var{keymap} This clause iterates over all key sequences defined by @var{keymap} @@ -2602,13 +2598,13 @@ clause to get the command bindings as well. @item for @var{var} being the overlays [of @var{buffer}] @dots{} -This clause iterates over the Emacs 19 ``overlays'' or Lucid -Emacs ``extents'' of a buffer (the clause @code{extents} is synonymous -with @code{overlays}). Under Emacs 18, this clause iterates zero -times. If the @code{of} term is omitted, the current buffer is used. -This clause also accepts optional @samp{from @var{pos}} and -@samp{to @var{pos}} terms, limiting the clause to overlays which -overlap the specified region. +This clause iterates over the Emacs 19 ``overlays'' or XEmacs +``extents'' of a buffer (the clause @code{extents} is synonymous with +@code{overlays}). Under Emacs 18, this clause iterates zero times. If +the @code{of} term is omitted, the current buffer is used. This clause +also accepts optional @samp{from @var{pos}} and @samp{to @var{pos}} +terms, limiting the clause to overlays which overlap the specified +region. @item for @var{var} being the intervals [of @var{buffer}] @dots{} This clause iterates over all intervals of a buffer with constant @@ -3217,7 +3213,7 @@ @example (declaim (inline foo bar)) (eval-when (compile load eval) (proclaim '(inline foo bar))) -(proclaim-inline foo bar) ; Lucid Emacs only +(proclaim-inline foo bar) ; XEmacs only (defsubst foo (...) ...) ; instead of defun; Emacs 19 only @end example @@ -4601,6 +4597,10 @@ @chapter Hash Tables @noindent +Hash tables are now implemented directly in the C code and documented in +@ref{Hash Tables,,, lispref, XEmacs Lisp Programmer's Manual}. + +@ignore A @dfn{hash table} is a data structure that maps ``keys'' onto ``values.'' Keys and values can be arbitrary Lisp data objects. Hash tables have the property that the time to search for a given @@ -4622,14 +4622,14 @@ the hashing function described below to make sure it is suitable for your predicate. -Some versions of Emacs (like Lucid Emacs 19) include a built-in -hash table type; in these versions, @code{make-hash-table} with -a test of @code{eq} will use these built-in hash tables. In all -other cases, it will return a hash-table object which takes the -form of a list with an identifying ``tag'' symbol at the front. -All of the hash table functions in this package can operate on -both types of hash table; normally you will never know which -type is being used. +Some versions of Emacs (like XEmacs) include a built-in hash +table type; in these versions, @code{make-hash-table} with a test of +@code{eq}, @code{eql}, or @code{equal} will use these built-in hash +tables. In all other cases, it will return a hash-table object which +takes the form of a list with an identifying ``tag'' symbol at the +front. All of the hash table functions in this package can operate on +both types of hash table; normally you will never know which type is +being used. This function accepts the additional Common Lisp keywords @code{:rehash-size} and @code{:rehash-threshold}, but it ignores @@ -4670,22 +4670,20 @@ an alternate way of iterating over hash tables. @end defun -@defun hash-table-count table -This function returns the number of entries in @var{table}. -@strong{Warning:} The current implementation of Lucid Emacs 19 -hash-tables does not decrement the stored @code{count} when -@code{remhash} removes an entry. Therefore, the return value of -this function is not dependable if you have used @code{remhash} -on the table and the table's test is @code{eq}. A slower, but -reliable, way to count the entries is @code{(loop for x being the -hash-keys of @var{table} count t)}. +@defun hash-table-count table This function returns the number of +entries in @var{table}. @strong{Warning:} The current implementation of +XEmacs hash-tables does not decrement the stored @code{count} +when @code{remhash} removes an entry. Therefore, the return value of +this function is not dependable if you have used @code{remhash} on the +table and the table's test is @code{eq}, @code{eql}, or @code{equal}. +A slower, but reliable, way to count the entries is +@code{(loop for x being the hash-keys of @var{table} count t)}. @end defun -@defun hash-table-p object -This function returns @code{t} if @var{object} is a hash table, -@code{nil} otherwise. It recognizes both types of hash tables -(both Lucid Emacs built-in tables and tables implemented with -special lists.) +@defun hash-table-p object This function returns @code{t} if +@var{object} is a hash table, @code{nil} otherwise. It recognizes both +types of hash tables (both XEmacs built-in tables and tables implemented +with special lists.) @end defun Sometimes when dealing with hash tables it is useful to know the @@ -4745,6 +4743,7 @@ converting the key to a string or looking it up in an obarray. However, such tables are guaranteed to take time proportional to their size to do a search. +@end ignore @iftex @chapno=18 @@ -5581,7 +5580,7 @@ (mapcar (function (lambda (x) (* x 2))) list) ; Emacs Lisp @end example -Lucid Emacs supports @code{#'} notation starting with version 19.8. +XEmacs supports @code{#'} notation starting with version 19.8. @item Reader macros. Common Lisp includes a second type of macro that diff -r 76b7d63099ad -r 8626e4521993 man/internals/internals.texi --- a/man/internals/internals.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/internals/internals.texi Mon Aug 13 11:07:10 2007 +0200 @@ -8,7 +8,7 @@ Copyright @copyright{} 1992 - 1996 Ben Wing. Copyright @copyright{} 1996, 1997 Sun Microsystems. -Copyright @copyright{} 1994, 1995 Free Software Foundation. +Copyright @copyright{} 1994 - 1998 Free Software Foundation. Copyright @copyright{} 1994, 1995 Board of Trustees, University of Illinois. @@ -59,22 +59,23 @@ @titlepage @title XEmacs Internals Manual -@subtitle Version 1.1, March 1997 +@subtitle Version 1.2, October 1998 @author Ben Wing @author Martin Buchholz +@author Hrvoje Niksic @page @vskip 0pt plus 1fill @noindent Copyright @copyright{} 1992 - 1996 Ben Wing. @* -Copyright @copyright{} 1996 Sun Microsystems, Inc. @* -Copyright @copyright{} 1994 Free Software Foundation. @* +Copyright @copyright{} 1996, 1997 Sun Microsystems, Inc. @* +Copyright @copyright{} 1994 - 1998 Free Software Foundation. @* Copyright @copyright{} 1994, 1995 Board of Trustees, University of Illinois. @sp 2 -Version 1.1 @* -March, 1997.@* +Version 1.2 @* +October 1998.@* Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are @@ -180,7 +181,7 @@ * Symbol:: * Marker:: * String:: -* Bytecode:: +* Compiled Function:: Events and the Event Loop @@ -908,10 +909,43 @@ providing the increased compile-time error-checking of static typing. @end enumerate +The Java language also has some negative attributes: + +@enumerate +@item +Java uses the edit/compile/run model of software development. This +makes it hard to use interactively. For example, to use Java like +@code{bc} it is necessary to write a special purpose, albeit tiny, +application. In Emacs Lisp, a calculator comes built-in without any +effort - one can always just type an expression in the @code{*scratch*} +buffer. +@item +Java tries too hard to enforce, not merely enable, portability, making +ordinary access to standard OS facilities painful. Java has an +@dfn{agenda}. I think this is why @code{chdir} is not part of standard +Java, which is inexcusable. +@end enumerate + +Unfortunately, there is no perfect language. Static typing allows a +compiler to catch programmer errors and produce more efficient code, but +makes programming more tedious and less fun. For the forseeable future, +an Ideal Editing and Programming Environment (and that is what XEmacs +aspires to) will be programmable in multiple languages: high level ones +like Lisp for user customization and prototyping, and lower level ones +for infrastructure and industrial strength applications. If I had my +way, XEmacs would be friendly towards the Python, Scheme, C++, ML, +etc... communities. But there are serious technical difficulties to +achieving that goal. + +The word @dfn{application} in the previous paragraph was used +intentionally. XEmacs implements an API for programs written in Lisp +that makes it a full-fledged application platform, very much like an OS +inside the real OS. + @node XEmacs From the Perspective of Building, XEmacs From the Inside, The Lisp Language, Top @chapter XEmacs From the Perspective of Building - The heart of XEmacs is the Lisp environment, which is written in C. +The heart of XEmacs is the Lisp environment, which is written in C. This is contained in the @file{src/} subdirectory. Underneath @file{src/} are two subdirectories of header files: @file{s/} (header files for particular operating systems) and @file{m/} (header files for @@ -923,26 +957,26 @@ 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. - - The @file{lwlib/} directory contains C code that implements a +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 generalized interface onto different X widget toolkits and also implements some widgets of its own that behave like Motif widgets but are faster, free, and in some cases more powerful. The code in this directory compiles into a library and is mostly independent from XEmacs. - The @file{etc/} directory contains various data files associated with +The @file{etc/} directory contains various data files associated with XEmacs. Some of them are actually read by XEmacs at startup; others merely contain useful information of various sorts. - The @file{lib-src/} directory contains C code for various auxiliary +The @file{lib-src/} directory contains C code for various auxiliary programs that are used in connection with XEmacs. Some of them are used during the build process; others are used to perform certain functions that cannot conveniently be placed in the XEmacs executable (e.g. the @@ -951,59 +985,64 @@ @file{gnuclient} program, which allows an external script to communicate with a running XEmacs process). - The @file{man/} directory contains the sources for the XEmacs +The @file{man/} directory contains the sources for the XEmacs documentation. It is mostly in a form called Texinfo, which can be converted into either a printed document (by passing it through @TeX{}) or into on-line documentation called @dfn{info files}. - The @file{info/} directory contains the results of formatting the -XEmacs documentation as @dfn{info files}, for on-line use. These files -are used when you enter the Info system using @kbd{C-h i} or through the +The @file{info/} directory contains the results of formatting the XEmacs +documentation as @dfn{info files}, for on-line use. These files are +used when you enter the Info system using @kbd{C-h i} or through the Help menu. - The @file{dynodump/} directory contains auxiliary code used to build +The @file{dynodump/} directory contains auxiliary code used to build XEmacs on Solaris platforms. - The other directories contain various miscellaneous code and -information that is not normally used or needed. - - The first step of building involves running the @file{configure} -program and passing it various parameters to specify any optional -features you want and compiler arguments and such, as described in the -@file{INSTALL} file. This determines what the build environment is, -chooses the appropriate @file{s/} and @file{m/} file, and runs a series -of tests to determine many details about your environment, such as which -library functions are available and exactly how they work. (The -@file{s/} and @file{m/} files only contain information that cannot be -conveniently detected in this fashion.) The reason for running these -tests is that it allows XEmacs to be compiled on a much wider variety of -platforms than those that the XEmacs developers happen to be familiar -with, including various sorts of hybrid platforms. This is especially -important now that many operating systems give you a great deal of -control over exactly what features you want installed, and allow for -easy upgrading of parts of a system without upgrading the rest. It +The other directories contain various miscellaneous code and information +that is not normally used or needed. + +The first step of building involves running the @file{configure} program +and passing it various parameters to specify any optional features you +want and compiler arguments and such, as described in the @file{INSTALL} +file. This determines what the build environment is, chooses the +appropriate @file{s/} and @file{m/} file, and runs a series of tests to +determine many details about your environment, such as which library +functions are available and exactly how they work. The reason for +running these tests is that it allows XEmacs to be compiled on a much +wider variety of platforms than those that the XEmacs developers happen +to be familiar with, including various sorts of hybrid platforms. This +is especially important now that many operating systems give you a great +deal of control over exactly what features you want installed, and allow +for easy upgrading of parts of a system without upgrading the rest. It would be impossible to pre-determine and pre-specify the information for all possible configurations. - When configure is done running, it generates @file{Makefile}s and the -file @file{src/config.h} (which describes the features of your system) -from template files. You then run @file{make}, which compiles the -auxiliary code and programs in @file{lib-src/} and @file{lwlib/} and the -main XEmacs executable in @file{src/}. The result of compiling and -linking is an executable called @file{temacs}, which is @emph{not} the -final XEmacs executable. @file{temacs} by itself is not intended to -function as an editor or even display any windows on the screen, and if -you simply run it, it will exit immediately. The @file{Makefile} runs -@file{temacs} with certain options that cause it to initialize itself, -read in a number of basic Lisp files, and then dump itself out into a -new executable called @file{xemacs}. This new executable has been -pre-initialized and contains pre-digested Lisp code that is necessary -for the editor to function (this includes most basic Lisp functions, -e.g. @code{not}, that can be defined in terms of other Lisp primitives; -some initialization code that is called when certain objects, such as -frames, are created; and all of the standard keybindings and code for -the actions they result in). This executable, @file{xemacs}, is the -executable that you run to use the XEmacs editor. +In fact, the @file{s/} and @file{m/} files are basically @emph{evil}, +since they contain unmaintainable platform-specific hard-coded +information. XEmacs has been moving in the direction of having all +system-specific information be determined dynamically by +@file{configure}. Perhaps someday we can @code{rm -rf src/s src/m}. + +When configure is done running, it generates @file{Makefile}s and +@file{GNUmakefile}s and the file @file{src/config.h} (which describes +the features of your system) from template files. You then run +@file{make}, which compiles the auxiliary code and programs in +@file{lib-src/} and @file{lwlib/} and the main XEmacs executable in +@file{src/}. The result of compiling and linking is an executable +called @file{temacs}, which is @emph{not} the final XEmacs executable. +@file{temacs} by itself is not intended to function as an editor or even +display any windows on the screen, and if you simply run it, it will +exit immediately. The @file{Makefile} runs @file{temacs} with certain +options that cause it to initialize itself, read in a number of basic +Lisp files, and then dump itself out into a new executable called +@file{xemacs}. This new executable has been pre-initialized and +contains pre-digested Lisp code that is necessary for the editor to +function (this includes most basic editing functions, +e.g. @code{kill-line}, that can be defined in terms of other Lisp +primitives; some initialization code that is called when certain +objects, such as frames, are created; and all of the standard +keybindings and code for the actions they result in). This executable, +@file{xemacs}, is the executable that you run to use the XEmacs editor. Although @file{temacs} is not intended to be run as an editor, it can, by using the incantation @code{temacs -batch -l loadup.el run-temacs}. @@ -1015,7 +1054,7 @@ @node XEmacs From the Inside, The XEmacs Object System (Abstractly Speaking), XEmacs From the Perspective of Building, Top @chapter XEmacs From the Inside - Internally, XEmacs is quite complex, and can be very confusing. To +Internally, XEmacs is quite complex, and can be very confusing. To simplify things, it can be useful to think of XEmacs as containing an event loop that ``drives'' everything, and a number of other subsystems, such as a Lisp engine and a redisplay mechanism. Each of these other @@ -1023,7 +1062,7 @@ state. The flow of control continually passes in and out of these different subsystems in the course of normal operation of the editor. - It is important to keep in mind that, most of the time, the editor is +It is important to keep in mind that, most of the time, the editor is ``driven'' by the event loop. Except during initialization and batch mode, all subsystems are entered directly or indirectly through the event loop, and ultimately, control exits out of all subsystems back up @@ -1031,7 +1070,7 @@ to the event loop, and starting another iteration of the event loop occurs once each keystroke, mouse motion, etc. - If you're trying to understand a particular subsystem (other than the +If you're trying to understand a particular subsystem (other than the event loop), think of it as a ``daemon'' process or ``servant'' that is responsible for one particular aspect of a larger system, and periodically receives commands or environment changes that cause it to @@ -1187,9 +1226,9 @@ @table @code @item integer -28 bits of precision, or 60 bits on 64-bit machines; the reason for this -is described below when the internal Lisp object representation is -described. +28 or 31 bits of precision, or 60 or 63 bits on 64-bit machines; the +reason for this is described below when the internal Lisp object +representation is described. @item float Same precision as a double in C. @item cons @@ -1223,29 +1262,30 @@ @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.) - - XEmacs Lisp also contains numerous specialized objects used to -implement the editor: +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: @table @code @item buffer @@ -1264,8 +1304,8 @@ equivalent to a @dfn{display} in the X Window System and a @dfn{TTY} in character mode. @item face -An object specifying the appearance of text or graphics; it contains -characteristics such as font, foreground color, and background color. +An object specifying the appearance of text or graphics; it has +properties such as font, foreground color, and background color. @item marker An object that refers to a particular position in a buffer and moves around as text is inserted and deleted to stay in the same relative @@ -1297,11 +1337,11 @@ There are some other, less-commonly-encountered general objects: @table @code -@item hashtable +@item hash-table An object that maps from an arbitrary Lisp object to another arbitrary Lisp object, using hashing for fast lookup. @item obarray -A limited form of hashtable that maps from strings to symbols; obarrays +A limited form of hash-table that maps from strings to symbols; obarrays are used to look up a symbol given its name and are not actually their own object type but are kludgily represented using vectors with hidden fields (this representation derives from GNU Emacs). @@ -1343,14 +1383,11 @@ communication protocol. @item toolbar-button An object used in conjunction with the toolbar. -@item x-resource -An object that encapsulates certain miscellaneous resources in the X -window system, used only when Epoch support is enabled. @end table And objects that are only used internally: -@table @asis +@table @code @item opaque A generic object for encapsulating arbitrary memory; this allows you the generality of @code{malloc()} and the convenience of the Lisp object @@ -1435,7 +1472,7 @@ (where @samp{^[} actually is an @samp{ESC} character) converts to a particular Kanji character when using an ISO2022-based coding system for -input. (To decode this gook: @samp{ESC} begins an escape sequence; +input. (To decode this goo: @samp{ESC} begins an escape sequence; @samp{ESC $ (} is a class of escape sequences meaning ``switch to a 94x94 character set''; @samp{ESC $ ( B} means ``switch to Japanese Kanji''; @samp{#} and @samp{&} collectively index into a 94-by-94 array @@ -1462,7 +1499,7 @@ @code{obarray}, whose contents should be an obarray. If no symbol is found, a new symbol with the name @code{"foobar"} is automatically created and added to @code{obarray}; this process is called -@dfn{interning} the symbol. +@dfn{interning} the symbol. @cindex interning @example @@ -1500,6 +1537,12 @@ converts to a bit-vector. @example +#s(hash-table ... ...) +@end example + +converts to a hash table (the actual contents are not shown). + +@example #s(range-table ... ...) @end example @@ -1510,25 +1553,26 @@ @end example converts to a char table (the actual contents are not shown). -(Note that the #s syntax is the general syntax for structures, -which are not really implemented in XEmacs Lisp but should be.) - - When an object is printed out (using @code{print} or a related + +Note that the @code{#s()} syntax is the general syntax for structures, +which are not really implemented in XEmacs Lisp but should be. + +When an object is printed out (using @code{print} or a related function), the read syntax is used, so that the same object can be read in again. - The other objects do not have read syntaxes, usually because it does -not really make sense to create them in this fashion (i.e. processes, -where it doesn't make sense to have a subprocess created as a side -effect of reading some Lisp code), or because they can't be created at -all (e.g. subrs). Permanent objects, as a rule, do not have a read -syntax; nor do most complex objects, which contain too much state to be -easily initialized through a read syntax. +The other objects do not have read syntaxes, usually because it does not +really make sense to create them in this fashion (i.e. processes, where +it doesn't make sense to have a subprocess created as a side effect of +reading some Lisp code), or because they can't be created at all +(e.g. subrs). Permanent objects, as a rule, do not have a read syntax; +nor do most complex objects, which contain too much state to be easily +initialized through a read syntax. @node How Lisp Objects Are Represented in C, Rules When Writing New C Code, The XEmacs Object System (Abstractly Speaking), Top @chapter How Lisp Objects Are Represented in C - Lisp objects are represented in C using a 32- or 64-bit machine word +Lisp objects are represented in C using a 32-bit or 64-bit machine word (depending on the processor; i.e. DEC Alphas use 64-bit Lisp objects and most other processors use 32-bit Lisp objects). The representation stuffs a pointer together with a tag, as follows: @@ -1537,33 +1581,31 @@ [ 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 -@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 + <---> ^ <------------------------------------------------------> + 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 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.) - - Lisp objects use the typedef @code{Lisp_Object}, but the actual C type +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 used for the Lisp object can vary. It can be either a simple type (@code{long} on the DEC Alpha, @code{int} on other machines) or a structure whose fields are bit fields that line up properly (actually, a -union of structures that's used). Generally the simple integral type is +union of structures is used). Generally the simple integral type is preferable because it ensures that the compiler will actually use a machine word to represent the object (some compilers will use more general and less efficient code for unions and structs even if they can @@ -1571,27 +1613,28 @@ stricter type checking (if you accidentally pass an integer where a Lisp object is desired, you get a compile error), and it makes it easier to decode Lisp objects when debugging. The choice of which type to use is -determined by the presence or absence of the preprocessor constant -@code{USE_UNION_TYPE}. +determined by the preprocessor constant @code{USE_UNION_TYPE} which is +defined via the @code{--use-union-type} option to @code{configure}. @cindex record type - Note that there are only eight types that the tag can represent, -but many more actual types than this. This is handled by having -one of the tag types specify a meta-type called a @dfn{record}; -for all such objects, the first four bytes of the pointed-to -structure indicate what the actual type is. - - Note also that having 28 bits for pointers and integers restricts a -lot of things to 256 megabytes of memory. (Basically, enough pointers -and indices and whatnot get stuffed into Lisp objects that the total -amount of memory used by XEmacs can't grow above 256 megabytes. In -older versions of XEmacs and GNU Emacs, the tag was 5 bits wide, -allowing for 32 types, which was more than the actual number of types -that existed at the time, and no ``record'' type was necessary. -However, this limited the editor to 64 megabytes total, which some users -who edited large files might conceivably exceed.) - - Also, note that there is an implicit assumption here that all pointers + +Note that there are only eight types that the tag can represent, but +many more actual types than this. This is handled by having one of the +tag types specify a meta-type called a @dfn{record}; for all such +objects, the first four bytes of the pointed-to structure indicate what +the actual type is. + +Note also that having 28 bits for pointers and integers restricts a lot +of things to 256 megabytes of memory. (Basically, enough pointers and +indices and whatnot get stuffed into Lisp objects that the total amount +of memory used by XEmacs can't grow above 256 megabytes. In older +versions of XEmacs and GNU Emacs, the tag was 5 bits wide, allowing for +32 types, which was more than the actual number of types that existed at +the time, and no ``record'' type was necessary. However, this limited +the editor to 64 megabytes total, which some users who edited large +files might conceivably exceed.) + +Also, note that there is an implicit assumption here that all pointers are low enough that the top bits are all zero and can just be chopped off. On standard machines that allocate memory from the bottom up (and give each process its own address space), this works fine. Some @@ -1601,13 +1644,56 @@ the proper mask. Then, pointers retrieved from Lisp objects are automatically OR'ed with this value prior to being used. - A corollary of the previous paragraph is that @strong{(pointers to) +A corollary of the previous paragraph is that @strong{(pointers to) stack-allocated structures cannot be put into Lisp objects}. The stack is generally located near the top of memory; if you put such a pointer into a Lisp object, it will get its top bits chopped off, and you will lose. - Various macros are used to construct Lisp objects and extract the +Actually, there's an alternative representation of a @code{Lisp_Object}, +invented by Kyle Jones, that is used when the +@code{--use-minimal-tagbits} option to @code{configure} is used. In +this case the 2 lower bits are used for the tag bits. This +representation assumes that pointers to structs are always aligned to +multiples of 4, so the lower 2 bits are always zero. + +@example + [ 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 ] + [ 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 ] + + <---------------------------------------------------------> <-> + a pointer to a structure, or an integer tag +@end example + +A tag of 00 is used for all pointer object types, a tag of 10 is used +for characters, and the other two tags 01 and 11 are joined together to +form the integer object type. The markbit is moved to part of the +structure being pointed at (integers and chars do not need to be marked, +since no memory is allocated). This representation has these +advantages: + +@enumerate +@item +31 bits can be used for Lisp Integers. +@item +@emph{Any} pointer can be represented directly, and no bit masking +operations are necessary. +@end enumerate + +The disadvantages are: + +@enumerate +@item +An extra level of indirection is needed when accessing the object types +that were not record types. So checking whether a Lisp object is a cons +cell becomes a slower operation. +@item +Mark bits can no longer be stored directly in Lisp objects, so another +place for them must be found. This means that a cons cell requires more +memory than merely room for 2 lisp objects, leading to extra memory use. +@end enumerate + +Various macros are used to construct Lisp objects and extract the components. Macros of the form @code{XINT()}, @code{XCHAR()}, @code{XSTRING()}, @code{XSYMBOL()}, etc. mask out the pointer/integer field and cast it to the appropriate type. All of the macros that @@ -1622,7 +1708,7 @@ complicated definition is selected by defining @code{EXPLICIT_SIGN_EXTEND}. - Note that when @code{ERROR_CHECK_TYPECHECK} is defined, the extractor +Note that when @code{ERROR_CHECK_TYPECHECK} is defined, the extractor macros become more complicated -- they check the tag bits and/or the type field in the first four bytes of a record type to ensure that the object is really of the correct type. This is great for catching places @@ -1630,8 +1716,9 @@ in a pointer being dereferenced as the wrong type of structure, with unpredictable (and sometimes not easily traceable) results. - There are similar @code{XSET@var{TYPE}()} macros that construct a Lisp object. -These macros are of the form @code{XSET@var{TYPE} (@var{lvalue}, @var{result})}, +There are similar @code{XSET@var{TYPE}()} macros that construct a Lisp +object. These macros are of the form @code{XSET@var{TYPE} +(@var{lvalue}, @var{result})}, i.e. they have to be a statement rather than just used in an expression. The reason for this is that standard C doesn't let you ``construct'' a structure (but GCC does). Granted, this sometimes isn't too convenient; @@ -1642,15 +1729,24 @@ structure is of the right type in the case of record types, where the type is contained in the structure. +The C programmer is responsible for @strong{guaranteeing} that a +Lisp_Object is is the correct type before using the @code{X@var{TYPE}} +macros. This is especially important in the case of lists. Use +@code{XCAR} and @code{XCDR} if a Lisp_Object is certainly a cons cell, +else use @code{Fcar()} and @code{Fcdr()}. Trust other C code, but not +Lisp code. On the other hand, if XEmacs has an internal logic error, +it's better to crash immediately, so sprinkle ``unreachable'' +@code{abort()}s liberally about the source code. + @node Rules When Writing New C Code, A Summary of the Various XEmacs Modules, How Lisp Objects Are Represented in C, Top @chapter Rules When Writing New C Code - The XEmacs C Code is extremely complex and intricate, and there are -many rules that are more or less consistently followed throughout the code. +The XEmacs C Code is extremely complex and intricate, and there are many +rules that are more or less consistently followed throughout the code. Many of these rules are not obvious, so they are explained here. It is -of the utmost importance that you follow them. If you don't, you may get -something that appears to work, but which will crash in odd situations, -often in code far away from where the actual breakage is. +of the utmost importance that you follow them. If you don't, you may +get something that appears to work, but which will crash in odd +situations, often in code far away from where the actual breakage is. @menu * General Coding Rules:: @@ -1663,7 +1759,15 @@ @node General Coding Rules @section General Coding Rules - Almost every module contains a @code{syms_of_*()} function and a +The C code is actually written in a dialect of C called @dfn{Clean C}, +meaning that it can be compiled, mostly warning-free, with either a C or +C++ compiler. Coding in Clean C has several advantages over plain C. +C++ compilers are more nit-picking, and a number of coding errors have +been found by compiling with C++. The ability to use both C and C++ +tools means that a greater variety of development tools are available to +the developer. + +Almost every module contains a @code{syms_of_*()} function and a @code{vars_of_*()} function. The former declares any Lisp primitives you have defined and defines any symbols you will be using. The latter declares any global Lisp variables you have added and initializes global @@ -1678,16 +1782,16 @@ though: You have to make sure your function is called at the right time so that all the initialization dependencies work out. - Every module includes @file{} (angle brackets so that +Every module includes @file{} (angle brackets so that @samp{--srcdir} works correctly; @file{config.h} may or may not be in the same directory as the C sources) and @file{lisp.h}. @file{config.h} -should always be included before any other header files (including +must always be included before any other header files (including system header files) to ensure that certain tricks played by various @file{s/} and @file{m/} files work out correctly. - @strong{All global and static variables that are to be modifiable must -be declared uninitialized.} This means that you may not use the ``declare -with initializer'' form for these variables, such as @code{int +@strong{All global and static variables that are to be modifiable must +be declared uninitialized.} This means that you may not use the +``declare with initializer'' form for these variables, such as @code{int some_variable = 0;}. The reason for this has to do with some kludges done during the dumping process: If possible, the initialized data segment is re-mapped so that it becomes part of the (unmodifiable) code @@ -1698,22 +1802,22 @@ the @file{temacs} phase. @cindex copy-on-write - @strong{Please note:} This kludge only works on a few systems -nowadays, and is rapidly becoming irrelevant because most modern -operating systems provide @dfn{copy-on-write} semantics. All data is -initially shared between processes, and a private copy is automatically -made (on a page-by-page basis) when a process first attempts to write to -a page of memory. - - Formerly, there was a requirement that static variables not be -declared inside of functions. This had to do with another hack along -the same vein as what was just described: old USG systems put -statically-declared variables in the initialized data space, so those -header files had a @code{#define static} declaration. (That way, the -data-segment remapping described above could still work.) This fails -badly on static variables inside of functions, which suddenly become -automatic variables; therefore, you weren't supposed to have any of -them. This awful kludge has been removed in XEmacs because +@strong{Please note:} This kludge only works on a few systems nowadays, +and is rapidly becoming irrelevant because most modern operating systems +provide @dfn{copy-on-write} semantics. All data is initially shared +between processes, and a private copy is automatically made (on a +page-by-page basis) when a process first attempts to write to a page of +memory. + +Formerly, there was a requirement that static variables not be declared +inside of functions. This had to do with another hack along the same +vein as what was just described: old USG systems put statically-declared +variables in the initialized data space, so those header files had a +@code{#define static} declaration. (That way, the data-segment remapping +described above could still work.) This fails badly on static variables +inside of functions, which suddenly become automatic variables; +therefore, you weren't supposed to have any of them. This awful kludge +has been removed in XEmacs because @enumerate @item @@ -1725,41 +1829,72 @@ 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); - - while (!NILP (args)) - @{ - val = Feval (XCAR (args)); - if (!NILP (val)) - break; - args = XCDR (args); - @} + val = Feval (XCAR (args)); + + GCPRO1 (val); + + LIST_LOOP_3 (form, XCDR (args), tail) + Feval (form); UNGCPRO; return val; @@ -1771,23 +1906,25 @@ @code{DEFUN} macro. Here is a template for them: @example -DEFUN (@var{lname}, @var{fname}, @var{min}, @var{max}, @var{interactive}, /* -@var{docstring} -*/ - (@var{arglist}) ) +@group +DEFUN (@var{lname}, @var{fname}, @var{min_args}, @var{max_args}, @var{interactive}, /* +@var{docstring} +*/ + (@var{arglist})) +@end group @end example @table @var @item lname This string is the name of the Lisp symbol to define as the function -name; in the example above, it is @code{"or"}. +name; in the example above, it is @code{"prog1"}. @item fname This is the C function name for this function. This is the name that is used in C code for calling the function. The name is, by convention, @samp{F} prepended to the Lisp name, with all dashes (@samp{-}) in the Lisp name changed to underscores. Thus, to call this function from C -code, call @code{For}. Remember that the arguments are of type +code, call @code{Fprog1}. Remember that the arguments are of type @code{Lisp_Object}; various macros and functions for creating values of type @code{Lisp_Object} are declared in the file @file{lisp.h}. @@ -1804,31 +1941,32 @@ 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. - -@item min +structure, since @code{DEFUN} plus @code{DEFSUBR} takes care of all the +details. + +@item min_args This is the minimum number of arguments that the function requires. The -function @code{or} allows a minimum of zero arguments. - -@item max +function @code{prog1} allows a minimum of one argument. + +@item max_args This is the maximum number of arguments that the function accepts, if there is a fixed maximum. Alternatively, it can be @code{UNEVALLED}, indicating a special form that receives unevaluated arguments, or @code{MANY}, indicating an unlimited number of evaluated arguments (the -equivalent of @code{&rest}). Both @code{UNEVALLED} and @code{MANY} are -macros. If @var{max} is a number, it may not be less than @var{min} and -it may not be greater than 8. (If you need to add a function with -more than 8 arguments, either use the @code{MANY} form or edit the -definition of @code{DEFUN} in @file{lisp.h}. If you do the latter, -make sure to also add another clause to the switch statement in -@code{primitive_funcall().}) +C equivalent of @code{&rest}). Both @code{UNEVALLED} and @code{MANY} +are macros. If @var{max_args} is a number, it may not be less than +@var{min_args} and it may not be greater than 8. (If you need to add a +function with more than 8 arguments, use the @code{MANY} form. Resist +the urge to edit the definition of @code{DEFUN} in @file{lisp.h}. If +you do it anyways, make sure to also add another clause to the switch +statement in @code{primitive_funcall().}) @item interactive This is an interactive specification, a string such as might be used as the argument of @code{interactive} in a Lisp function. In the case of -@code{or}, it is 0 (a null pointer), indicating that @code{or} cannot be -called interactively. A value of @code{""} indicates a function that -should receive no arguments when called interactively. +@code{prog1}, it is 0 (a null pointer), indicating that @code{prog1} +cannot be called interactively. A value of @code{""} indicates a +function that should receive no arguments when called interactively. @item docstring This is the documentation string. It is written just like a @@ -1841,18 +1979,18 @@ documentation strings, is very particular about what it looks for, and will not properly extract the doc string if it's not in this exact format. -You are free to put the various arguments to @code{DEFUN} on separate -lines to avoid overly long lines. However, make sure to put the -comment-start characters for the doc string on the same line as the -interactive specification, and put a newline directly after them (and -before the comment-end characters). +In order to make both @file{etags} and @file{make-docfile} happy, make +sure that the @code{DEFUN} line contains the @var{lname} and +@var{fname}, and that the comment-start characters for the doc string +are on the same line as the interactive specification, and put a newline +directly after them (and before the comment-end characters). @item arglist This is the comma-separated list of arguments to the C function. For a function with a fixed maximum number of arguments, provide a C argument for each Lisp argument. In this case, unlike regular C functions, the types of the arguments are not declared; they are simply always of type -@code{Lisp_Object}. +@code{Lisp_Object}. The names of the C arguments will be used as the names of the arguments to the Lisp primitive as displayed in its documentation, modulo the same @@ -1865,13 +2003,13 @@ @code{dirname}) to be used as argument names without compiler warnings or errors. -A Lisp function with @w{@var{max} = @code{UNEVALLED}} is a +A Lisp function with @w{@var{max_args} = @code{UNEVALLED}} is a @w{@dfn{special form}}; its arguments are not evaluated. Instead it receives one argument of type @code{Lisp_Object}, a (Lisp) list of the unevaluated arguments, conventionally named @code{(args)}. When a Lisp function has no upper limit on the number of arguments, -specify @w{@var{max} = @code{MANY}}. In this case its implementation in +specify @w{@var{max_args} = @code{MANY}}. In this case its implementation in C actually receives exactly two arguments: the number of Lisp arguments (an @code{int}) and the address of a block containing their values (a @w{@code{Lisp_Object *}}). In this case only are the C types specified @@ -1879,52 +2017,56 @@ @end table - Within the function @code{For} itself, note the use of the macros +Within the function @code{Fprog1} itself, note the use of the macros @code{GCPRO1} and @code{UNGCPRO}. @code{GCPRO1} is used to ``protect'' a variable from garbage collection---to inform the garbage collector -that it must look in that variable and regard its contents as an -accessible object. This is necessary whenever you call @code{Feval} or -anything that can directly or indirectly call @code{Feval} (this -includes the @code{QUIT} macro!). At such a time, any Lisp object that -you intend to refer to again must be protected somehow. @code{UNGCPRO} -cancels the protection of the variables that are protected in the -current function. It is necessary to do this explicitly. - - The macro @code{GCPRO1} protects just one local variable. If you want +that it must look in that variable and regard the object pointed at by +its contents as an accessible object. This is necessary whenever you +call @code{Feval} or anything that can directly or indirectly call +@code{Feval} (this includes the @code{QUIT} macro!). At such a time, +any Lisp object that you intend to refer to again must be protected +somehow. @code{UNGCPRO} cancels the protection of the variables that +are protected in the current function. It is necessary to do this +explicitly. + +The macro @code{GCPRO1} protects just one local variable. If you want to protect two, use @code{GCPRO2} instead; repeating @code{GCPRO1} will not work. Macros @code{GCPRO3} and @code{GCPRO4} also exist. - These macros implicitly use local variables such as @code{gcpro1}; you +These macros implicitly use local variables such as @code{gcpro1}; you must declare these explicitly, with type @code{struct gcpro}. Thus, if you use @code{GCPRO2}, you must declare @code{gcpro1} and @code{gcpro2}. @cindex caller-protects (@code{GCPRO} rule) - Note also that the general rule is @dfn{caller-protects}; i.e. you -are only responsible for protecting those Lisp objects that you create. -Any objects passed to you as parameters should have been protected -by whoever created them, so you don't in general have to protect them. -@code{For} is an exception; it protects its parameters to provide -extra assurance against Lisp primitives elsewhere that are incorrectly -written, and against malicious self-modifying code. There are a few -other standard functions that also do this. - -@code{GCPRO}ing is perhaps the trickiest and most error-prone part -of XEmacs coding. It is @strong{extremely} important that you get this +Note also that the general rule is @dfn{caller-protects}; i.e. you are +only responsible for protecting those Lisp objects that you create. Any +objects passed to you as arguments should have been protected by whoever +created them, so you don't in general have to protect them. + +In particular, the arguments to any Lisp primitive are always +automatically @code{GCPRO}ed, when called ``normally'' from Lisp code or +bytecode. So only a few Lisp primitives that are called frequently from +C code, such as @code{Fprogn} protect their arguments as a service to +their caller. You don't need to protect your arguments when writing a +new @code{DEFUN}. + +@code{GCPRO}ing is perhaps the trickiest and most error-prone part of +XEmacs coding. It is @strong{extremely} important that you get this right and use a great deal of discipline when writing this code. @xref{GCPROing, ,@code{GCPRO}ing}, for full details on how to do this. - What @code{DEFUN} actually does is declare a global structure of -type @code{Lisp_Subr} whose name begins with capital @samp{SF} and -which contains information about the primitive (e.g. a pointer to the +What @code{DEFUN} actually does is declare a global structure of type +@code{Lisp_Subr} whose name begins with capital @samp{SF} and which +contains information about the primitive (e.g. a pointer to the function, its minimum and maximum allowed arguments, a string describing -its Lisp name); @code{DEFUN} then begins a normal C function -declaration using the @code{F...} name. The Lisp subr object that is -the function definition of a primitive (i.e. the object in the function -slot of the symbol that names the primitive) actually points to this -@samp{SF} structure; when @code{Feval} encounters a subr, it looks in the +its Lisp name); @code{DEFUN} then begins a normal C function declaration +using the @code{F...} name. The Lisp subr object that is the function +definition of a primitive (i.e. the object in the function slot of the +symbol that names the primitive) actually points to this @samp{SF} +structure; when @code{Feval} encounters a subr, it looks in the structure to find out how to call the C function. - Defining the C function is not enough to make a Lisp primitive +Defining the C function is not enough to make a Lisp primitive available; you must also create the Lisp symbol for the primitive (the symbol is @dfn{interned}; @pxref{Obarrays}) and store a suitable subr object in its function cell. (If you don't do this, the primitive won't @@ -1934,17 +2076,16 @@ 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}. - - Note that C code cannot call functions by name unless they are defined +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 in C. The way to call a function written in Lisp from C is to use @code{Ffuncall}, which embodies the Lisp function @code{funcall}. Since the Lisp function @code{funcall} accepts an unlimited number of @@ -1954,21 +2095,21 @@ 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.) - - The C functions @code{call0}, @code{call1}, @code{call2}, and so on, +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, provide handy ways to call a Lisp function conveniently with a fixed number of arguments. They work by calling @code{Ffuncall}. - @file{eval.c} is a very good file to look through for examples; -@file{lisp.h} contains the definitions for some important macros and +@file{eval.c} is a very good file to look through for examples; +@file{lisp.h} contains the definitions for important macros and functions. @node Adding Global Lisp Variables @section Adding Global Lisp Variables - Global variables whose names begin with @samp{Q} are constants whose +Global variables whose names begin with @samp{Q} are constants whose value is a symbol of a particular name. The name of the variable should be derived from the name of the symbol using the same rules as for Lisp primitives. These variables are initialized using a call to @@ -2149,13 +2290,13 @@ ... @{ /* Allocate place for @var{cclen} characters. */ - Bufbyte *tmp_buf = (Bufbyte *)alloca (cclen * MAX_EMCHAR_LEN); + Bufbyte *buf = (Bufbyte *)alloca (cclen * MAX_EMCHAR_LEN); ... @end group @end example If you followed the previous section, you can guess that, logically, -multiplying a @code{Charcount} value with @code{MAX_EMCHAR_LEN} produces +multiplying a @code{Charcount} value with @code{MAX_EMCHAR_LEN} produces a @code{Bytecount} value. In the current Mule implementation, @code{MAX_EMCHAR_LEN} equals 4. @@ -2256,7 +2397,7 @@ This is because these returned strings may contain 8bit characters which can be misinterpreted by XEmacs, and cause a crash. Likewise, when exporting a piece of internal text to the outside world, you should -always convert it to an appropriate external encoding, lest the internal +always convert it to an appropriate external encoding, lest the internal stuff (such as the infamous \201 characters) leak out. The interface to conversion between the internal and external @@ -2265,7 +2406,7 @@ formats supported by these macros. Currently meaningful formats are @code{FORMAT_BINARY}, -@code{FORMAT_FILENAME}, @code{FORMAT_OS}, and @code{FORMAT_CTEXT}. Here +@code{FORMAT_FILENAME}, @code{FORMAT_OS}, and @code{FORMAT_CTEXT}. Here is a description of these. @table @code @@ -2299,7 +2440,7 @@ no-lock-shift ISO2022 coding system. @end table -The macros to convert between these formats and the internal format, and +The macros to convert between these formats and the internal format, and vice versa, follow. @table @code @@ -2379,13 +2520,13 @@ almost certainly do not need @code{Emchar *}. @item Be careful not to confuse @code{Charcount}, @code{Bytecount}, and @code{Bufpos}. -The whole point of using different types is to avoid confusion about the -use of certain variables. Lest this effect be nullified, you need to be +The whole point of using different types is to avoid confusion about the +use of certain variables. Lest this effect be nullified, you need to be careful about using the right types. @item Always convert external data It is extremely important to always convert external data, because -XEmacs can crash if unexpected 8bit sequences are copied to its internal +XEmacs can crash if unexpected 8bit sequences are copied to its internal buffers literally. This means that when a system function, such as @code{readdir}, returns @@ -2446,8 +2587,8 @@ @code{set_charptr_emchar} stores it to storage, increasing @code{p} in the process. -Other instructing examples of correct coding under Mule can be found all -over XEmacs code. For starters, I recommend +Other instructive examples of correct coding under Mule can be found all +over the XEmacs code. For starters, I recommend @code{Fnormalize_menu_item_name} in @file{menubar.c}. After you have understood this section of the manual and studied the examples, you can proceed writing new Mule-aware code. @@ -2458,7 +2599,7 @@ To make a quantified XEmacs, do: @code{make quantmacs}. You simply can't dump Quantified and Purified images. Run the image -like so: @code{quantmacs -batch -l loadup.el run-temacs -q}. +like so: @code{quantmacs -batch -l loadup.el run-temacs @var{xemacs-args...}}. Before you go through the trouble, are you compiling with all debugging and error-checking off? If not try that first. Be warned @@ -2475,46 +2616,85 @@ commands: @code{quantify-start-recording-data}, @code{quantify-stop-recording-data} and @code{quantify-clear-data}. +If you want to make XEmacs faster, target your favorite slow benchmark, +run a profiler like Quantify, @code{gprof}, or @code{tcov}, and figure +out where the cycles are going. Specific projects: + +@itemize @bullet +@item +Make the garbage collector faster. Figure out how to write an +incremental garbage collector. +@item +Write a compiler that takes bytecode and spits out C code. +Unfortunately, you will then need a C compiler and a more fully +developed module system. +@item +Speed up redisplay. +@item +Speed up syntax highlighting. Maybe moving some of the syntax +highlighting capabilities into C would make a difference. +@item +Implement tail recursion in Emacs Lisp (hard!). +@end itemize + +Unfortunately, Emacs Lisp is slow, and is going to stay slow. Function +calls in elisp are especially expensive. Iterating over a long list is +going to be 30 times faster implemented in C than in Elisp. + To get started debugging XEmacs, take a look at the @file{gdbinit} and -@file{dbxrc} files in the @file{src} directory. -@xref{Q2.1.15 - How to Debug an XEmacs problem with a debugger,,, +@file{dbxrc} files in the @file{src} directory. +@xref{Q2.1.15 - How to Debug an XEmacs problem with a debugger,,, xemacs-faq, XEmacs FAQ}. +After making source code changes, run @code{make check} to ensure that +you haven't introduced any regressions. If you're feeling ambitious, +you can try to improve the test suite in @file{tests/automated}. Here are things to know when you create a new source file: @itemize @bullet @item -All .c files should @code{#include } first. Almost all .c -files should @code{#include "lisp.h"} second. - -@item -Generated header files should be included using the @code{<>} syntax, -not the @code{""} syntax. The generated headers are: - -config.h puresize-adjust.h sheap-adjust.h paths.h Emacs.ad.h +All @file{.c} files should @code{#include } first. Almost all +@file{.c} files should @code{#include "lisp.h"} second. + +@item +Generated header files should be included using the @code{#include <...>} syntax, +not the @code{#include "..."} syntax. The generated headers are: + +@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}. - -@item -Header files should not include and "lisp.h". It is the -responsibility of the .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 -Try compiling at least once with +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 @emph{not} include @code{} and +@code{"lisp.h"}. It is the responsibility of the @file{.c} files that +use it to do so. + +@item +If the header uses @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 @example gcc --with-mule --with-union-type --error-checking=all @end example + +@item +Did I mention that you should run the test suite? +@example +make check +@end example @end itemize + @node A Summary of the Various XEmacs Modules, Allocation of Objects in XEmacs Lisp, Rules When Writing New C Code, Top @chapter A Summary of the Various XEmacs Modules @@ -2539,9 +2719,7 @@ @section Low-Level Modules @example - size name -------- --------------------- - 18150 config.h +config.h @end example This is automatically generated from @file{config.h.in} based on the @@ -2552,7 +2730,7 @@ @example - 2347 paths.h +paths.h @end example This is automatically generated from @file{paths.h.in} based on supplied @@ -2562,8 +2740,8 @@ @example - 47878 emacs.c - 20239 signal.c +emacs.c +signal.c @end example @file{emacs.c} contains @code{main()} and other code that performs the most @@ -2583,23 +2761,23 @@ @example - 23458 unexaix.c - 9893 unexalpha.c - 11302 unexapollo.c - 16544 unexconvex.c - 31967 unexec.c - 30959 unexelf.c - 35791 unexelfsgi.c - 3207 unexencap.c - 7276 unexenix.c - 20539 unexfreebsd.c - 1153 unexfx2800.c - 13432 unexhp9k3.c - 11049 unexhp9k800.c - 9165 unexmips.c - 8981 unexnext.c - 1673 unexsol2.c - 19261 unexsunos4.c +unexaix.c +unexalpha.c +unexapollo.c +unexconvex.c +unexec.c +unexelf.c +unexelfsgi.c +unexencap.c +unexenix.c +unexfreebsd.c +unexfx2800.c +unexhp9k3.c +unexhp9k800.c +unexmips.c +unexnext.c +unexsol2.c +unexsunos4.c @end example These modules contain code dumping out the XEmacs executable on various @@ -2611,9 +2789,9 @@ @example - 15715 crt0.c - 1484 lastfile.c - 1115 pre-crt0.c +crt0.c +lastfile.c +pre-crt0.c @end example These modules are used in conjunction with the dump mechanism. On some @@ -2638,14 +2816,14 @@ @example - 14786 alloca.c - 16678 free-hook.c - 1692 getpagesize.h - 41936 gmalloc.c - 25141 malloc.c - 3802 mem-limits.h - 39011 ralloc.c - 3436 vm-limit.c +alloca.c +free-hook.c +getpagesize.h +gmalloc.c +malloc.c +mem-limits.h +ralloc.c +vm-limit.c @end example These handle basic C allocation of memory. @file{alloca.c} is an emulation of @@ -2663,20 +2841,21 @@ fixed now.) @cindex relocating allocator -@file{ralloc.c} is the @dfn{relocating allocator}. It provides functions -similar to @code{malloc()}, @code{realloc()} and @code{free()} that allocate -memory that can be dynamically relocated in memory. The advantage of -this is that allocated memory can be shuffled around to place all the -free memory at the end of the heap, and the heap can then be shrunk, -releasing the memory back to the operating system. The use of this can -be controlled with the configure option @code{--rel-alloc}; if enabled, memory allocated for -buffers will be relocatable, so that if a very large file is visited and -the buffer is later killed, the memory can be released to the operating -system. (The disadvantage of this mechanism is that it can be very -slow. On systems with the @code{mmap()} system call, the XEmacs version -of @file{ralloc.c} uses this to move memory around without actually having to -block-copy it, which can speed things up; but it can still cause -noticeable performance degradation.) +@file{ralloc.c} is the @dfn{relocating allocator}. It provides +functions similar to @code{malloc()}, @code{realloc()} and @code{free()} +that allocate memory that can be dynamically relocated in memory. The +advantage of this is that allocated memory can be shuffled around to +place all the free memory at the end of the heap, and the heap can then +be shrunk, releasing the memory back to the operating system. The use +of this can be controlled with the configure option @code{--rel-alloc}; +if enabled, memory allocated for buffers will be relocatable, so that if +a very large file is visited and the buffer is later killed, the memory +can be released to the operating system. (The disadvantage of this +mechanism is that it can be very slow. On systems with the +@code{mmap()} system call, the XEmacs version of @file{ralloc.c} uses +this to move memory around without actually having to block-copy it, +which can speed things up; but it can still cause noticeable performance +degradation.) @file{free-hook.c} contains some debugging functions for checking for invalid arguments to @code{free()}. @@ -2693,10 +2872,9 @@ @example - 2659 blocktype.c - 1410 blocktype.h - 7194 dynarr.c - 2671 dynarr.h +blocktype.c +blocktype.h +dynarr.c @end example These implement a couple of basic C data types to facilitate memory @@ -2720,7 +2898,7 @@ @example - 2058 inline.c +inline.c @end example This module is used in connection with inline functions (available in @@ -2734,8 +2912,8 @@ @example - 6489 debug.c - 2267 debug.h +debug.c +debug.h @end example These functions provide a system for doing internal consistency checks @@ -2746,7 +2924,7 @@ @example - 1643 prefix-args.c +prefix-args.c @end example This is actually the source for a small, self-contained program @@ -2754,7 +2932,7 @@ @example - 904 universe.h +universe.h @end example This is not currently used. @@ -2765,14 +2943,12 @@ @section Basic Lisp Modules @example - size name -------- --------------------- - 70167 emacsfns.h - 6305 lisp-disunion.h - 7086 lisp-union.h - 54929 lisp.h - 14235 lrecord.h - 10728 symsinit.h +emacsfns.h +lisp-disunion.h +lisp-union.h +lisp.h +lrecord.h +symsinit.h @end example These are the basic header files for all XEmacs modules. Each module @@ -2792,7 +2968,7 @@ As a general rule, all typedefs should go into the typedefs section of @file{lisp.h} rather than into a module-specific header file even if the structure is defined elsewhere. This allows function prototypes that -use the typedef to be placed into @file{emacsfns.h}. Forward structure +use the typedef to placed into other header files. Forward structure declarations (i.e. a simple declaration like @code{struct foo;} where the structure itself is defined elsewhere) should be placed into the typedefs section as necessary. @@ -2802,20 +2978,22 @@ 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}. - - - -@example - 120478 alloc.c - 1029 pure.c - 2506 puresize.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 +alloc.c +pure.c +puresize.h @end example The large module @file{alloc.c} implements all of the basic allocation and @@ -2872,8 +3050,8 @@ @example - 122243 eval.c - 2305 backtrace.h +eval.c +backtrace.h @end example This module contains all of the functions to handle the flow of control. @@ -2892,7 +3070,7 @@ @example - 64949 lread.c +lread.c @end example This module implements the Lisp reader and the @code{read} function, @@ -2903,7 +3081,7 @@ @example - 40900 print.c +print.c @end example This module implements the Lisp print mechanism and the @code{print} @@ -2915,9 +3093,9 @@ @example - 4518 general.c - 60220 symbols.c - 9966 symeval.h +general.c +symbols.c +symeval.h @end example @file{symbols.c} implements the handling of symbols, obarrays, and @@ -2935,9 +3113,9 @@ @example - 48973 data.c - 25694 floatfns.c - 71049 fns.c +data.c +floatfns.c +fns.c @end example These modules implement the methods and standard Lisp primitives for all @@ -2956,13 +3134,13 @@ @example - 23555 bytecode.c - 3358 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. +bytecode.c +bytecode.h +@end example + +@file{bytecode.c} implements the byte-code interpreter and +compiled-function objects, and @file{bytecode.h} contains associated +structures. Note that the byte-code @emph{compiler} is written in Lisp. @@ -2971,11 +3149,9 @@ @section Modules for Standard Editing Operations @example - size name -------- --------------------- - 82900 buffer.c - 60964 buffer.h - 6059 bufslots.h +buffer.c +buffer.h +bufslots.h @end example @file{buffer.c} implements the @dfn{buffer} Lisp object type. This @@ -3004,8 +3180,8 @@ @example - 79888 insdel.c - 6103 insdel.h +insdel.c +insdel.h @end example @file{insdel.c} contains low-level functions for inserting and deleting text in @@ -3019,7 +3195,7 @@ @example - 10975 marker.c +marker.c @end example This module implements the @dfn{marker} Lisp object type, which @@ -3038,8 +3214,8 @@ @example - 193714 extents.c - 15686 extents.h +extents.c +extents.h @end example This module implements the @dfn{extent} Lisp object type, which is like @@ -3059,7 +3235,7 @@ @example - 60155 editfns.c +editfns.c @end example @file{editfns.c} contains the standard Lisp primitives for working with @@ -3076,9 +3252,9 @@ @example - 26081 callint.c - 12577 cmds.c - 2749 commands.h +callint.c +cmds.c +commands.h @end example @cindex interactive @@ -3105,9 +3281,9 @@ @example - 194863 regex.c - 18968 regex.h - 79800 search.c +regex.c +regex.h +search.c @end example @file{search.c} implements the Lisp primitives for searching for text in @@ -3122,7 +3298,7 @@ @example - 20476 doprnt.c +doprnt.c @end example @file{doprnt.c} implements formatted-string processing, similar to @@ -3131,7 +3307,7 @@ @example - 15372 undo.c +undo.c @end example This module implements the undo mechanism for tracking buffer changes. @@ -3143,13 +3319,11 @@ @section Editor-Level Control Flow Modules @example - size name -------- --------------------- - 84546 event-Xt.c - 121483 event-stream.c - 6658 event-tty.c - 49271 events.c - 14459 events.h +event-Xt.c +event-stream.c +event-tty.c +events.c +events.h @end example These implement the handling of events (user input and other system @@ -3189,8 +3363,8 @@ @example - 129583 keymap.c - 2621 keymap.h +keymap.c +keymap.h @end example @file{keymap.c} and @file{keymap.h} define the @dfn{keymap} Lisp object @@ -3202,7 +3376,7 @@ @example - 25212 keyboard.c +keyboard.c @end example @file{keyboard.c} contains functions that implement the actual editor @@ -3213,8 +3387,8 @@ @example - 9973 macros.c - 1397 macros.h +macros.c +macros.h @end example These two modules contain the basic code for defining keyboard macros. @@ -3224,7 +3398,7 @@ @example - 23234 minibuf.c +minibuf.c @end example This contains some miscellaneous code related to the minibuffer (most of @@ -3243,17 +3417,15 @@ @section Modules for the Basic Displayable Lisp Objects @example - size name -------- --------------------- - 985 device-ns.h - 6454 device-stream.c - 1196 device-stream.h - 9526 device-tty.c - 8660 device-tty.h - 43798 device-x.c - 11667 device-x.h - 26056 device.c - 22993 device.h +device-ns.h +device-stream.c +device-stream.h +device-tty.c +device-tty.h +device-x.c +device-x.h +device.c +device.h @end example These modules implement the @dfn{device} Lisp object type. This @@ -3272,12 +3444,12 @@ @example - 934 frame-ns.h - 2303 frame-tty.c - 69205 frame-x.c - 5976 frame-x.h - 68175 frame.c - 15080 frame.h +frame-ns.h +frame-tty.c +frame-x.c +frame-x.h +frame.c +frame.h @end example Each device contains one or more frames in which objects (e.g. text) are @@ -3294,8 +3466,8 @@ @example - 160783 window.c - 15974 window.h +window.c +window.h @end example @cindex window (in Emacs) @@ -3319,63 +3491,61 @@ @section Modules for other Display-Related Lisp Objects @example - size name -------- --------------------- - 54397 faces.c - 15173 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 -@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 -@end example - - - -@example - 57511 menubar-x.c - 11243 menubar.c -@end example - - - -@example - 25012 scrollbar-x.c - 2554 scrollbar-x.h - 26954 scrollbar.c - 2778 scrollbar.h -@end example - - - -@example - 23117 toolbar-x.c - 43456 toolbar.c - 4280 toolbar.h -@end example - - - -@example - 25070 font-lock.c +faces.c +faces.h +@end example + + + +@example +bitmaps.h +glyphs-ns.h +glyphs-x.c +glyphs-x.h +glyphs.c +glyphs.h +@end example + + + +@example +objects-ns.h +objects-tty.c +objects-tty.h +objects-x.c +objects-x.h +objects.c +objects.h +@end example + + + +@example +menubar-x.c +menubar.c +@end example + + + +@example +scrollbar-x.c +scrollbar-x.h +scrollbar.c +scrollbar.h +@end example + + + +@example +toolbar-x.c +toolbar.c +toolbar.h +@end example + + + +@example +font-lock.c @end example This file provides C support for syntax highlighting -- i.e. @@ -3386,10 +3556,10 @@ @example - 32180 dgif_lib.c - 3999 gif_err.c - 10697 gif_lib.h - 9371 gifalloc.c +dgif_lib.c +gif_err.c +gif_lib.h +gifalloc.c @end example These modules decode GIF-format image files, for use with glyphs. @@ -3400,13 +3570,11 @@ @section Modules for the Redisplay Mechanism @example - size name -------- --------------------- - 38692 redisplay-output.c - 40835 redisplay-tty.c - 65069 redisplay-x.c - 234142 redisplay.c - 17026 redisplay.h +redisplay-output.c +redisplay-tty.c +redisplay-x.c +redisplay.c +redisplay.h @end example These files provide the redisplay mechanism. As with many other @@ -3437,7 +3605,7 @@ @example - 14129 indent.c +indent.c @end example This module contains various functions and Lisp primitives for @@ -3449,9 +3617,9 @@ @example - 14754 termcap.c - 2141 terminfo.c - 7253 tparam.c +termcap.c +terminfo.c +tparam.c @end example These files contain functions for working with the termcap (BSD-style) @@ -3461,8 +3629,8 @@ @example - 10869 cm.c - 5876 cm.h +cm.c +cm.h @end example These files provide some miscellaneous TTY-output functions and should @@ -3474,10 +3642,8 @@ @section Modules for Interfacing with the File System @example - size name -------- --------------------- - 43362 lstream.c - 14240 lstream.h +lstream.c +lstream.h @end example These modules implement the @dfn{stream} Lisp object type. This is an @@ -3504,7 +3670,7 @@ @example - 126926 fileio.c +fileio.c @end example This implements the basic primitives for interfacing with the file @@ -3521,7 +3687,7 @@ @example - 10960 filelock.c +filelock.c @end example This file provides functions for detecting clashes between different @@ -3536,7 +3702,7 @@ @example - 4527 filemode.c +filemode.c @end example This file provides some miscellaneous functions that construct a @@ -3547,8 +3713,8 @@ @example - 22855 dired.c - 2094 ndir.h +dired.c +ndir.h @end example These files implement the XEmacs interface to directory searching. This @@ -3564,7 +3730,7 @@ @example - 4311 realpath.c +realpath.c @end example This file provides an implementation of the @code{realpath()} function @@ -3577,25 +3743,24 @@ @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 -@end example - -These files implement the @dfn{hashtable} Lisp object type. +elhash.c +elhash.h +hash.c +hash.h +@end example + +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. - - - -@example - 95691 specifier.c - 11167 specifier.h +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 +specifier.c +specifier.h @end example This module implements the @dfn{specifier} Lisp object type. This is @@ -3611,9 +3776,9 @@ @example - 43058 chartab.c - 6503 chartab.h - 9918 casetab.c +chartab.c +chartab.h +casetab.c @end example @file{chartab.c} and @file{chartab.h} implement the @dfn{char table} @@ -3633,8 +3798,8 @@ @example - 49593 syntax.c - 10200 syntax.h +syntax.c +syntax.h @end example @cindex scanner @@ -3651,7 +3816,7 @@ @example - 10438 casefiddle.c +casefiddle.c @end example This module implements various Lisp primitives for upcasing, downcasing @@ -3660,7 +3825,7 @@ @example - 20234 rangetab.c +rangetab.c @end example This module implements the @dfn{range table} Lisp object type, which @@ -3670,8 +3835,8 @@ @example - 3201 opaque.c - 2206 opaque.h +opaque.c +opaque.h @end example This module implements the @dfn{opaque} Lisp object type, an @@ -3693,7 +3858,7 @@ @example - 8783 abbrev.c +abbrev.c @end example This function provides a few primitives for doing dynamic abbreviation @@ -3706,7 +3871,7 @@ @example - 21934 doc.c +doc.c @end example This function provides primitives for retrieving the documentation @@ -3725,7 +3890,7 @@ @example - 13197 md5.c +md5.c @end example This function provides a Lisp primitive that implements the MD5 secure @@ -3740,11 +3905,9 @@ @section Modules for Interfacing with the Operating System @example - size name -------- --------------------- - 33533 callproc.c - 89697 process.c - 4663 process.h +callproc.c +process.c +process.h @end example These modules allow XEmacs to spawn and communicate with subprocesses @@ -3789,8 +3952,8 @@ @example - 136029 sysdep.c - 5986 sysdep.h +sysdep.c +sysdep.h @end example These modules implement most of the low-level, messy operating-system @@ -3803,15 +3966,15 @@ @example - 3605 sysdir.h - 6708 sysfile.h - 2027 sysfloat.h - 2918 sysproc.h - 745 syspwd.h - 7643 syssignal.h - 6892 systime.h - 12477 systty.h - 3487 syswait.h +sysdir.h +sysfile.h +sysfloat.h +sysproc.h +syspwd.h +syssignal.h +systime.h +systty.h +syswait.h @end example These header files provide consistent interfaces onto system-dependent @@ -3866,15 +4029,15 @@ @example - 7940 hpplay.c - 10920 libsst.c - 1480 libsst.h - 3260 libst.h - 15355 linuxplay.c - 15849 nas.c - 19133 sgiplay.c - 15411 sound.c - 7358 sunplay.c +hpplay.c +libsst.c +libsst.h +libst.h +linuxplay.c +nas.c +sgiplay.c +sound.c +sunplay.c @end example These files implement the ability to play various sounds on some types @@ -3911,8 +4074,8 @@ @example - 44368 tooltalk.c - 2137 tooltalk.h +tooltalk.c +tooltalk.h @end example These two modules implement an interface to the ToolTalk protocol, which @@ -3928,7 +4091,7 @@ @example - 22695 getloadavg.c +getloadavg.c @end example This module provides the ability to retrieve the system's current load @@ -3938,21 +4101,7 @@ @example - 148520 energize.c - 6896 energize.h -@end example - -This module provides code to interface to an Energize server (when -XEmacs is used as part of Lucid's Energize development environment) and -provides some other Energize-specific functions. Much of the code in -this module should be made more general-purpose and moved elsewhere, but -is no longer very relevant now that Lucid is defunct. It also hasn't -worked since version 19.12, since nobody has been maintaining it. - - - -@example - 2861 sunpro.c +sunpro.c @end example This module provides a small amount of code used internally at Sun to @@ -3961,10 +4110,10 @@ @example - 5548 broken-sun.h - 3468 strcmp.c - 2179 strcpy.c - 1650 sunOS-fix.c +broken-sun.h +strcmp.c +strcpy.c +sunOS-fix.c @end example These files provide replacement functions and prototypes to fix numerous @@ -3973,7 +4122,7 @@ @example - 11669 hftctl.c +hftctl.c @end example This module provides some terminal-control code necessary on versions of @@ -3982,27 +4131,8 @@ @example - 1776 acldef.h - 1602 chpdef.h - 9032 uaf.h - 105 vlimit.h - 7145 vms-pp.c - 1158 vms-pwd.h - 26532 vmsfns.c - 6038 vmsmap.c - 695 vmspaths.h - 17482 vmsproc.c - 469 vmsproc.h -@end example - -All of these files are used for VMS support, which has never worked in -XEmacs. - - - -@example - 28316 msdos.c - 1472 msdos.h +msdos.c +msdos.h @end example These modules are used for MS-DOS support, which does not work in @@ -4014,9 +4144,7 @@ @section Modules for Interfacing with X Windows @example - size name -------- --------------------- - 3196 Emacs.ad.h +Emacs.ad.h @end example A file generated from @file{Emacs.ad}, which contains XEmacs-supplied @@ -4025,9 +4153,9 @@ @example - 24242 EmacsFrame.c - 6979 EmacsFrame.h - 3351 EmacsFrameP.h +EmacsFrame.c +EmacsFrame.h +EmacsFrameP.h @end example These modules implement an Xt widget class that encapsulates a frame. @@ -4042,9 +4170,9 @@ @example - 8178 EmacsManager.c - 1967 EmacsManager.h - 1895 EmacsManagerP.h +EmacsManager.c +EmacsManager.h +EmacsManagerP.h @end example These modules implement a simple Xt manager (i.e. composite) widget @@ -4054,10 +4182,10 @@ @example - 13188 EmacsShell-sub.c - 4588 EmacsShell.c - 2180 EmacsShell.h - 3133 EmacsShellP.h +EmacsShell-sub.c +EmacsShell.c +EmacsShell.h +EmacsShellP.h @end example These modules implement two Xt widget classes that are subclasses of @@ -4068,8 +4196,8 @@ @example - 9673 xgccache.c - 1111 xgccache.h +xgccache.c +xgccache.h @end example These modules provide functions for maintenance and caching of GC's @@ -4079,7 +4207,7 @@ @example - 69181 xselect.c +xselect.c @end example @cindex selections @@ -4090,10 +4218,10 @@ @example - 929 xintrinsic.h - 1038 xintrinsicp.h - 1579 xmmanagerp.h - 1585 xmprimitivep.h +xintrinsic.h +xintrinsicp.h +xmmanagerp.h +xmprimitivep.h @end example These header files are similar in spirit to the @file{sys*.h} files and buffer @@ -4113,8 +4241,8 @@ @example - 16930 xmu.c - 936 xmu.h +xmu.c +xmu.h @end example These files provide an emulation of the Xmu library for those systems @@ -4123,17 +4251,17 @@ @example - 4201 ExternalClient-Xlib.c - 18083 ExternalClient.c - 2035 ExternalClient.h - 2104 ExternalClientP.h - 22684 ExternalShell.c - 1709 ExternalShell.h - 1971 ExternalShellP.h - 2478 extw-Xlib.c - 1481 extw-Xlib.h - 6565 extw-Xt.c - 1430 extw-Xt.h +ExternalClient-Xlib.c +ExternalClient.c +ExternalClient.h +ExternalClientP.h +ExternalShell.c +ExternalShell.h +ExternalShellP.h +extw-Xlib.c +extw-Xlib.h +extw-Xt.c +extw-Xt.h @end example @cindex external widget @@ -4154,31 +4282,20 @@ -@example - 31014 epoch.c -@end example - -This file provides some additional, Epoch-compatible, functionality for -interfacing to the X Window System. - - - @node Modules for Internationalization @section Modules for Internationalization @example - size name -------- --------------------- - 42836 mule-canna.c - 16737 mule-ccl.c - 41080 mule-charset.c - 30176 mule-charset.h - 146844 mule-coding.c - 16588 mule-coding.h - 6996 mule-mcpath.c - 2899 mule-mcpath.h - 57158 mule-wnnfns.c - 3351 mule.c +mule-canna.c +mule-ccl.c +mule-charset.c +mule-charset.h +mule-coding.c +mule-coding.h +mule-mcpath.c +mule-mcpath.h +mule-wnnfns.c +mule.c @end example These files implement the MULE (Asian-language) support. Note that MULE @@ -4190,7 +4307,7 @@ XEmacs MULE support. @file{mule-charset.*} implements the @dfn{charset} Lisp object type, which encapsulates a character set (an ordered one- or two-dimensional set of characters, such as US ASCII or JISX0208 Japanese -Kanji). +Kanji). @file{mule-coding.*} implements the @dfn{coding-system} Lisp object type, which encapsulates a method of converting between different @@ -4223,7 +4340,7 @@ @example - 9400 intl.c +intl.c @end example This provides some miscellaneous internationalization code for @@ -4233,7 +4350,7 @@ @example - 1764 iso-wide.h +iso-wide.h @end example This contains leftover code from an earlier implementation of @@ -4260,7 +4377,7 @@ * Symbol:: * Marker:: * String:: -* Bytecode:: +* Compiled Function:: @end menu @node Introduction to Allocation @@ -4294,7 +4411,7 @@ (a) Those for whom the value directly represents the contents of the Lisp object. Only two types are in this category: integers and characters. No special allocation or garbage collection is necessary -for such objects. Lisp objects of these types do not need to be +for such objects. Lisp objects of these types do not need to be @code{GCPRO}ed. @end itemize @@ -4337,13 +4454,13 @@ @item (c) Those lrecords that are allocated in frob blocks (see above). This includes the objects that are most common and relatively small, and -includes floats, bytecodes, symbols (when not in category (b)), extents, -events, and markers. With the cleanup of frob blocks done in 19.12, -it's not terribly hard to add more objects to this category, but it's a -bit trickier than adding an object type to type (d) (esp. if the object -needs a finalization method), and is not likely to save much space -unless the object is small and there are many of them. (In fact, if -there are very few of them, it might actually waste space.) +includes floats, compiled functions, symbols (when not in category (b)), +extents, events, and markers. With the cleanup of frob blocks done in +19.12, it's not terribly hard to add more objects to this category, but +it's a bit trickier than adding an object type to type (d) (esp. if the +object needs a finalization method), and is not likely to save much +space unless the object is small and there are many of them. (In fact, +if there are very few of them, it might actually waste space.) @item (d) Those lrecords that are individually @code{malloc()}ed. These are called @dfn{lcrecords}. All other types are in this category. Adding a @@ -5071,8 +5188,8 @@ The string compactor recognizes this special 0xFFFFFFFF marker and handles it correctly. -@node Bytecode -@section Bytecode +@node Compiled Function +@section Compiled Function Not yet documented. @@ -5205,12 +5322,12 @@ @noindent @example - asynch. asynch. asynch. asynch. [Collectors in -kbd events kbd events process process the OS] - | | output output - | | | | - | | | | SIGINT, [signal handlers - | | | | SIGQUIT, in XEmacs] + asynch. asynch. asynch. asynch. [Collectors in +kbd events kbd events process process the OS] + | | output output + | | | | + | | | | SIGINT, [signal handlers + | | | | SIGQUIT, in XEmacs] V V V V SIGWINCH, file file file file SIGALRM desc. desc. desc. desc. | @@ -5224,27 +5341,27 @@ | | | | | | V V V V V V ------>-----------<----------------<---------------- - | - | - | [collected using select() in emacs_tty_next_event() - | and converted to the appropriate Emacs event] - | - | - V (above this line is TTY-specific) - Emacs ------------------------------------------------ - event (below this line is the generic event mechanism) - | - | -was there if not, call -a SIGINT? emacs_tty_next_event() - | | - | | - | | - V V - --->-------<---- + | + | + | [collected using select() in emacs_tty_next_event() + | and converted to the appropriate Emacs event] + | + | + V (above this line is TTY-specific) + Emacs ----------------------------------------------- + event (below this line is the generic event mechanism) + | + | +was there if not, call +a SIGINT? emacs_tty_next_event() + | | + | | + | | + V V + --->------<---- | - | [collected in event_stream_next_event(); - | SIGINT is converted using maybe_read_quit_event()] + | [collected in event_stream_next_event(); + | SIGINT is converted using maybe_read_quit_event()] V Emacs event @@ -5254,9 +5371,9 @@ | | command event queue | - if not from command - (contains events that were event queue, call - read earlier but not processed, event_stream_next_event() + if not from command + (contains events that were event queue, call + read earlier but not processed, event_stream_next_event() typically when waiting in a | sit-for, sleep-for, etc. for | a particular event to be received) | @@ -5265,8 +5382,8 @@ V V ---->------------------------------------<---- | - | [collected in - | next_event_internal()] + | [collected in + | next_event_internal()] | unread- unread- event from | command- command- keyboard else, call @@ -5308,45 +5425,45 @@ @example asynch. asynch. asynch. asynch. [Collectors in kbd kbd process process the OS] -events events output output - | | | | - | | | | asynch. asynch. [Collectors in the - | | | | X X OS and X Window System] - | | | | events events +events events output output + | | | | + | | | | asynch. asynch. [Collectors in the + | | | | X X OS and X Window System] + | | | | events events | | | | | | | | | | | | - | | | | | | SIGINT, [signal handlers - | | | | | | SIGQUIT, in XEmacs] - | | | | | | SIGWINCH, - | | | | | | SIGALRM - | | | | | | | - | | | | | | | - | | | | | | | timeouts + | | | | | | SIGINT, [signal handlers + | | | | | | SIGQUIT, in XEmacs] + | | | | | | SIGWINCH, + | | | | | | SIGALRM + | | | | | | | + | | | | | | | + | | | | | | | timeouts | | | | | | | | | | | | | | | | | | | | | | V | - V V V V V V fake | - file file file file file file file | - desc. desc. desc. desc. desc. desc. desc. | - (TTY) (TTY) (pipe) (pipe) (socket) (socket) (pipe) | + V V V V V V fake | + file file file file file file file | + desc. desc. desc. desc. desc. desc. desc. | + (TTY) (TTY) (pipe) (pipe) (socket) (socket) (pipe) | | | | | | | | | | | | | | | | | | | | | | | | | - V V V V V V V V + V V V V V V V V --->----------------------------------------<---------<------ | | | - | | | [collected using select() in - | | | _XtWaitForSomething(), called - | | | from XtAppProcessEvent(), called - | | | in emacs_Xt_next_event(); - | | | dispatched to various callbacks] + | | |[collected using select() in + | | | _XtWaitForSomething(), called + | | | from XtAppProcessEvent(), called + | | | in emacs_Xt_next_event(); + | | | dispatched to various callbacks] | | | | | | - emacs_Xt_ p_s_callback(), | [popup_selection_callback] - event_handler() x_u_v_s_callback(),| [x_update_vertical_scrollbar_ - | x_u_h_s_callback(),| callback] - | search_callback() | [x_update_horizontal_scrollbar_ - | | | callback] + emacs_Xt_ p_s_callback(), | [popup_selection_callback] + event_handler() x_u_v_s_callback(),| [x_update_vertical_scrollbar_ + | x_u_h_s_callback(),| callback] + | search_callback() | [x_update_horizontal_scrollbar_ + | | | callback] | | | | | | enqueue_Xt_ signal_special_ | @@ -5362,7 +5479,7 @@ -->----------<-- | | | | | - dispatch Xt_what_callback() + dispatch Xt_what_callback() event sets flags queue | | | @@ -5370,15 +5487,15 @@ | | | | ---->-----------<-------- - | + | | | [collected and converted as appropriate in | emacs_Xt_next_event()] - | - | - V (above this line is Xt-specific) - Emacs ------------------------------------------------ - event (below this line is the generic event mechanism) + | + | + V (above this line is Xt-specific) + Emacs ------------------------------------------------ + event (below this line is the generic event mechanism) | | was there if not, call @@ -5400,9 +5517,9 @@ | | command event queue | - if not from command - (contains events that were event queue, call - read earlier but not processed, event_stream_next_event() + if not from command + (contains events that were event queue, call + read earlier but not processed, event_stream_next_event() typically when waiting in a | sit-for, sleep-for, etc. for | a particular event to be received) | @@ -5411,8 +5528,8 @@ V V ---->----------------------------------<------ | - | [collected in - | next_event_internal()] + | [collected in + | next_event_internal()] | unread- unread- event from | command- command- keyboard else, call @@ -5495,79 +5612,129 @@ @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()}. - - @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. - - @code{Ffuncall()} implements Lisp @code{funcall}. @code{(funcall fun +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 + +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 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. - - @code{Fapply()} implements Lisp @code{apply}, which is very similar to +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{funcall} except that if the last argument is a list, the result is the same as if each of the arguments in the list had been passed separately. @code{Fapply()} does some business to expand the last argument if it's a list, then calls @code{Ffuncall()} to do the work. - @code{apply1()}, @code{call0()}, @code{call1()}, @code{call2()}, and +@code{apply1()}, @code{call0()}, @code{call1()}, @code{call2()}, and @code{call3()} call a function, passing it the argument(s) given (the arguments are given as separate C arguments rather than being passed as -an array). @code{apply1()} uses @code{apply} while the others use -@code{funcall}. +an array). @code{apply1()} uses @code{Fapply()} while the others use +@code{Ffuncall()} to do the real work. @node Dynamic Binding; The specbinding Stack; Unwind-Protects @section Dynamic Binding; The specbinding Stack; Unwind-Protects @@ -5575,7 +5742,8 @@ @example struct specbinding @{ - Lisp_Object symbol, old_value; + Lisp_Object symbol; + Lisp_Object old_value; Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */ @}; @end example @@ -5629,13 +5797,15 @@ @code{prog1}, @code{prog2}, @code{setq}, @code{quote}, @code{function}, @code{let*}, @code{let}, @code{while} - All of these are very simple and work as expected, calling +All of these are very simple and work as expected, calling @code{Feval()} or @code{Fprogn()} as necessary and (in the case of @code{let} and @code{let*}) using @code{specbind()} to create bindings -and @code{unbind_to()} to undo the bindings when finished. Note that -these functions do a lot of @code{GCPRO}ing to protect their arguments -from garbage collection because they call @code{Feval()} (@pxref{Garbage -Collection}). +and @code{unbind_to()} to undo the bindings when finished. + +Note that, with the exeption of @code{Fprogn}, these functions are +typically called in real life only in interpreted code, since the byte +compiler knows how to convert calls to these functions directly into +byte code. @node Catch and Throw @section Catch and Throw @@ -5887,7 +6057,7 @@ gets restored when the code is finished). However, calling @code{set-buffer} will NOT cause a permanent change in the current buffer. The reason for this is that the top-level event loop sets -@code{current_buffer} to the buffer of the selected window, each time +@code{current_buffer} to the buffer of the selected window, each time it finishes executing a user command. @end enumerate @@ -6348,7 +6518,7 @@ @node Japanese EUC (Extended Unix Code) @subsection Japanese EUC (Extended Unix Code) -This encompasses the character sets Printing-ASCII, Japanese-JISSX0201, +This encompasses the character sets Printing-ASCII, Japanese-JISX0201, and Japanese-JISX0208-Kana (half-width katakana, the right half of JISX0201). It uses 8-bit bytes. @@ -6538,45 +6708,45 @@ @example CCL PROGRAM SYNTAX: - CCL_PROGRAM := (CCL_MAIN_BLOCK - [ CCL_EOF_BLOCK ]) - - CCL_MAIN_BLOCK := CCL_BLOCK - CCL_EOF_BLOCK := CCL_BLOCK - - CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...]) - STATEMENT := - SET | IF | BRANCH | LOOP | REPEAT | BREAK - | READ | WRITE - - SET := (REG = EXPRESSION) | (REG SELF_OP EXPRESSION) - | INT-OR-CHAR - - EXPRESSION := ARG | (EXPRESSION OP ARG) - - IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK) - BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...]) - LOOP := (loop STATEMENT [STATEMENT ...]) - BREAK := (break) - REPEAT := (repeat) - | (write-repeat [REG | INT-OR-CHAR | string]) - | (write-read-repeat REG [INT-OR-CHAR | string | ARRAY]?) - READ := (read REG) | (read REG REG) - | (read-if REG ARITH_OP ARG CCL_BLOCK CCL_BLOCK) - | (read-branch REG CCL_BLOCK [CCL_BLOCK ...]) - WRITE := (write REG) | (write REG REG) - | (write INT-OR-CHAR) | (write STRING) | STRING - | (write REG ARRAY) - END := (end) - - REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 - ARG := REG | INT-OR-CHAR - OP := + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // - | < | > | == | <= | >= | != - SELF_OP := - += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= - ARRAY := '[' INT-OR-CHAR ... ']' - INT-OR-CHAR := INT | CHAR + CCL_PROGRAM := (CCL_MAIN_BLOCK + [ CCL_EOF_BLOCK ]) + + CCL_MAIN_BLOCK := CCL_BLOCK + CCL_EOF_BLOCK := CCL_BLOCK + + CCL_BLOCK := STATEMENT | (STATEMENT [STATEMENT ...]) + STATEMENT := + SET | IF | BRANCH | LOOP | REPEAT | BREAK + | READ | WRITE + + SET := (REG = EXPRESSION) | (REG SELF_OP EXPRESSION) + | INT-OR-CHAR + + EXPRESSION := ARG | (EXPRESSION OP ARG) + + IF := (if EXPRESSION CCL_BLOCK CCL_BLOCK) + BRANCH := (branch EXPRESSION CCL_BLOCK [CCL_BLOCK ...]) + LOOP := (loop STATEMENT [STATEMENT ...]) + BREAK := (break) + REPEAT := (repeat) + | (write-repeat [REG | INT-OR-CHAR | string]) + | (write-read-repeat REG [INT-OR-CHAR | string | ARRAY]?) + READ := (read REG) | (read REG REG) + | (read-if REG ARITH_OP ARG CCL_BLOCK CCL_BLOCK) + | (read-branch REG CCL_BLOCK [CCL_BLOCK ...]) + WRITE := (write REG) | (write REG REG) + | (write INT-OR-CHAR) | (write STRING) | STRING + | (write REG ARRAY) + END := (end) + + REG := r0 | r1 | r2 | r3 | r4 | r5 | r6 | r7 + ARG := REG | INT-OR-CHAR + OP := + | - | * | / | % | & | '|' | ^ | << | >> | <8 | >8 | // + | < | > | == | <= | >= | != + SELF_OP := + += | -= | *= | /= | %= | &= | '|=' | ^= | <<= | >>= + ARRAY := '[' INT-OR-CHAR ... ']' + INT-OR-CHAR := INT | CHAR MACHINE CODE: @@ -6596,13 +6766,13 @@ CCCCCCCCCCCCCCC: constant or address 000000000000rrr: register number -AAAA: 00000 + - 00001 - - 00010 * - 00011 / - 00100 % - 00101 & - 00110 | +AAAA: 00000 + + 00001 - + 00010 * + 00011 / + 00100 % + 00101 & + 00110 | 00111 ~ 01000 << @@ -6614,8 +6784,8 @@ 01110 not used 01111 not used - 10000 < - 10001 > + 10000 < + 10001 > 10010 == 10011 <= 10100 >= @@ -6623,78 +6793,78 @@ 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 - -SetSelfCS: 10111 RRR C...C RRR AAAAA= C...C +End: 10110 000 ..... terminate the execution + +SetSelfCS: 10111 RRR C...C RRR AAAAA= C...C ..........AAAAA -SetSelfCL: 11000 RRR ..... RRR AAAAA= c...c +SetSelfCL: 11000 RRR ..... RRR AAAAA= c...c c.............c ..........AAAAA -SetSelfR: 11001 RRR ..Rrr RRR AAAAA= rrr +SetSelfR: 11001 RRR ..Rrr RRR AAAAA= rrr ..........AAAAA -SetExprCL: 11010 RRR ..Rrr RRR = rrr AAAAA c...c +SetExprCL: 11010 RRR ..Rrr RRR = rrr AAAAA c...c c.............c ..........AAAAA -SetExprR: 11011 RRR ..rrr RRR = rrr AAAAA Rrr +SetExprR: 11011 RRR ..rrr RRR = rrr AAAAA Rrr ............Rrr ..........AAAAA -JumpCondC: 11100 RRR c...c if !(RRR AAAAA C..) jump to c...c +JumpCondC: 11100 RRR c...c if !(RRR AAAAA C..) jump to c...c C.............C ..........AAAAA -JumpCondR: 11101 RRR c...c if !(RRR AAAAA rrr) jump to c...c +JumpCondR: 11101 RRR c...c if !(RRR AAAAA rrr) jump to c...c ............rrr ..........AAAAA -ReadJumpCondC: 11110 RRR c...c Read1 and JumpCondC +ReadJumpCondC: 11110 RRR c...c Read1 and JumpCondC C.............C ..........AAAAA -ReadJumpCondR: 11111 RRR c...c Read1 and JumpCondR +ReadJumpCondR: 11111 RRR c...c Read1 and JumpCondR ............rrr ..........AAAAA @end example @@ -6969,7 +7139,7 @@ Thus, there is a hierarchy console -> display -> frame -> window. There is a separate Lisp object type for each of these four concepts. -Furthermore, there is logically a @dfn{selected console}, +Furthermore, there is logically a @dfn{selected console}, @dfn{selected display}, @dfn{selected frame}, and @dfn{selected window}. Each of these objects is distinguished in various ways, such as being the default object for various functions that act on objects of that type. @@ -7365,9 +7535,10 @@ or @dfn{display} order is as follows: @example -Extent A is ``less than'' extent B, that is, earlier in the display order, -if: A-start < B-start, -or if: A-start = B-start, and A-end > B-end +Extent A is ``less than'' extent B, +that is, earlier in the display order, + if: A-start < B-start, + or if: A-start = B-start, and A-end > B-end @end example So if two extents begin at the same position, the larger of them is the @@ -7376,9 +7547,10 @@ For the e-order, the same thing holds: @example -Extent A is ``less than'' extent B in e-order, that is, later in the buffer, -if: A-end < B-end, -or if: A-end = B-end, and A-start > B-start +Extent A is ``less than'' extent B in e-order, +that is, later in the buffer, + if: A-end < B-end, + or if: A-end = B-end, and A-start > B-start @end example So if two extents end at the same position, the smaller of them is the diff -r 76b7d63099ad -r 8626e4521993 man/lispref/building.texi --- a/man/lispref/building.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/lispref/building.texi Mon Aug 13 11:07:10 2007 +0200 @@ -358,8 +358,8 @@ frames-used 3 frame-storage 624 image-instances-used 47 image-instance-storage 3008 windows-used 27 windows-freed 2 window-storage 9180 lcrecord-lists-used 15 -lcrecord-list-storage 360 hashtables-used 631 -hashtable-storage 25240 streams-used 1 streams-on-free-list 3 +lcrecord-list-storage 360 hash-tables-used 631 +hash-table-storage 25240 streams-used 1 streams-on-free-list 3 streams-freed 12 stream-storage 91)) @end group @end example diff -r 76b7d63099ad -r 8626e4521993 man/lispref/compile.texi --- a/man/lispref/compile.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/lispref/compile.texi Mon Aug 13 11:07:10 2007 +0200 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the XEmacs Lisp Reference Manual. -@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. @c See the file lispref.texi for copying conditions. @setfilename ../../info/compile.info @node Byte Compilation, Debugging, Loading, Top @@ -24,6 +24,13 @@ by recent earlier versions of Emacs, but the reverse is not true. In particular, if you compile a program with XEmacs 20, the compiled code may not run in earlier versions. + +The first time a compiled-function object is executed, the byte-code +instructions are validated and the byte-code is further optimized. An +@code{invalid-byte-code} error is signaled if the byte-code is invalid, +for example if it contains invalid opcodes. This usually means a bug in +the byte compiler. + @iftex @xref{Docs and Compilation}. @end iftex @@ -53,7 +60,7 @@ (defun silly-loop (n) "Return time before and after N iterations of a loop." (let ((t1 (current-time-string))) - (while (> (setq n (1- n)) + (while (> (setq n (1- n)) 0)) (list t1 (current-time-string)))) @result{} silly-loop @@ -61,14 +68,13 @@ @group (silly-loop 5000000) -@result{} ("Fri Nov 28 20:56:16 1997" - "Fri Nov 28 20:56:39 1997") ; @r{23 seconds} +@result{} ("Mon Sep 14 15:51:49 1998" + "Mon Sep 14 15:52:07 1998") ; @r{18 seconds} @end group @group (byte-compile 'silly-loop) @result{} #}. However, if the variable @code{print-readably} is -non-@code{nil}, the object is printed beginning with @samp{#[} and -ending with @samp{]}. This representation can be read directly -by the Lisp reader, and is used in byte-compiled files (those ending -in @samp{.elc}). + The printed representation for a compiled-function object normally +begins with @samp{#}. However, +if the variable @code{print-readably} is non-@code{nil}, the object is +printed beginning with @samp{#[} and ending with @samp{]}. This +representation can be read directly by the Lisp reader, and is used in +byte-compiled files (those ending in @samp{.elc}). In Emacs version 18, there was no compiled-function object data type; compiled functions used the function @code{byte-code} to run the byte code. - A compiled-function object has a number of different elements. + A compiled-function object has a number of different attributes. They are: @table @var @@ -445,7 +451,7 @@ The vector of Lisp objects referenced by the byte code. These include symbols used as function names and variable names. -@item stacksize +@item stack-size The maximum stack size this function needs. @item doc-string @@ -470,8 +476,8 @@ @code{backward-sexp}. @example -# @end example @@ -479,9 +485,9 @@ The primitive way to create a compiled-function object is with @code{make-byte-code}: -@defun make-byte-code &rest elements +@defun make-byte-code arglist instructions constants stack-size &optional doc-string interactive This function constructs and returns a compiled-function object -with @var{elements} as its elements. +with the specified attributes. @emph{Please note:} Unlike all other Emacs-lisp functions, calling this with five arguments is @emph{not} the same as calling it with six arguments, @@ -571,9 +577,6 @@ Here are two examples of using the @code{disassemble} function. We have added explanatory comments to help you relate the byte-code to the Lisp source; these do not appear in the output of @code{disassemble}. -These examples show unoptimized byte-code. Nowadays byte-code is -usually optimized, but we did not want to rewrite these examples, since -they still serve their purpose. @example @group @@ -597,12 +600,12 @@ @end group @group -0 constant 1 ; @r{Push 1 onto stack.} - -1 varref integer ; @r{Get value of @code{integer}} +0 varref integer ; @r{Get value of @code{integer}} ; @r{from the environment} ; @r{and push the value} ; @r{onto the stack.} + +1 constant 1 ; @r{Push 1 onto stack.} @end group @group @@ -612,39 +615,35 @@ @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 +7:1 varref integer ; @r{Push value of @code{integer} onto stack.} + @group -10 constant * ; @r{Push symbol @code{*} onto stack.} - -11 varref integer ; @r{Push value of @code{integer} onto stack.} -@end group +8 constant factorial ; @r{Push @code{factorial} onto stack.} -@group -12 constant factorial ; @r{Push @code{factorial} onto stack.} +9 varref integer ; @r{Push value of @code{integer} onto stack.} -13 varref integer ; @r{Push value of @code{integer} onto stack.} - -14 sub1 ; @r{Pop @code{integer}, decrement value,} +10 sub1 ; @r{Pop @code{integer}, decrement value,} ; @r{push new value onto stack.} @end group @group ; @r{Stack now contains:} ; @minus{} @r{decremented value of @code{integer}} - ; @minus{} @r{@code{factorial}} + ; @minus{} @r{@code{factorial}} ; @minus{} @r{value of @code{integer}} - ; @minus{} @r{@code{*}} @end group @group @@ -659,20 +658,16 @@ ; @minus{} @r{result of recursive} ; @r{call to @code{factorial}} ; @minus{} @r{value of @code{integer}} - ; @minus{} @r{@code{*}} @end group @group -16 call 2 ; @r{Using the first two} - ; @r{(i.e., the top two)} - ; @r{elements of the stack} - ; @r{as arguments,} - ; @r{call the function @code{*},} +12 mult ; @r{Pop top two values off the stack,} + ; @r{multiply them,} ; @r{pushing the result onto the stack.} @end group @group -17 return ; @r{Return the top element} +13 return ; @r{Return the top element} ; @r{of the stack.} @result{} nil @end group @@ -685,7 +680,7 @@ (defun silly-loop (n) "Return time before and after N iterations of a loop." (let ((t1 (current-time-string))) - (while (> (setq n (1- n)) + (while (> (setq n (1- n)) 0)) (list t1 (current-time-string)))) @result{} silly-loop @@ -714,7 +709,7 @@ @end group @group -3 varref n ; @r{Get value of @code{n} from} +3:1 varref n ; @r{Get value of @code{n} from} ; @r{the environment and push} ; @r{the value onto the stack.} @end group @@ -728,11 +723,9 @@ ; @r{i.e., copy the top of} ; @r{the stack and push the} ; @r{copy onto the stack.} -@end group -@group 6 varset n ; @r{Pop the top of the stack,} - ; @r{and bind @code{n} to the value.} + ; @r{and set @code{n} to the value.} ; @r{In effect, the sequence @code{dup varset}} ; @r{copies the top of the stack} @@ -742,69 +735,43 @@ @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).} -@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).} +11 varref t1 ; @r{Push value of @code{t1} onto stack.} @end group @group -14 goto 3 ; @r{Jump back to beginning} - ; @r{of while loop.} -@end group - -@group -17 discard ; @r{Discard result of while loop} - ; @r{by popping top of stack.} - ; @r{This result is the value @code{nil} that} - ; @r{was not popped by the goto at 9.} -@end group - -@group -18 varref t1 ; @r{Push value of @code{t1} onto stack.} -@end group - -@group -19 constant current-time-string ; @r{Push} +12 constant current-time-string ; @r{Push} ; @r{@code{current-time-string}} ; @r{onto top of stack.} @end group @group -20 call 0 ; @r{Call @code{current-time-string} again.} +13 call 0 ; @r{Call @code{current-time-string} again.} + +14 unbind 1 ; @r{Unbind @code{t1} in local environment.} @end group @group -21 list2 ; @r{Pop top two elements off stack,} +15 list2 ; @r{Pop top two elements off stack,} ; @r{create a list of them,} ; @r{and push list onto stack.} @end group @group -22 unbind 1 ; @r{Unbind @code{t1} in local environment.} - -23 return ; @r{Return value of the top of stack.} +16 return ; @r{Return the top element of the stack.} @result{} nil @end group diff -r 76b7d63099ad -r 8626e4521993 man/lispref/errors.texi --- a/man/lispref/errors.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/lispref/errors.texi Mon Aug 13 11:07:10 2007 +0200 @@ -87,6 +87,10 @@ This is a @code{file-error}.@* @xref{Modification Time}. +@item invalid-byte-code +@code{"Invalid byte code"}@* +@xref{Byte Compilation}. + @item invalid-function @code{"Invalid function"}@* @xref{Classifying Lists}. diff -r 76b7d63099ad -r 8626e4521993 man/lispref/hash-tables.texi --- a/man/lispref/hash-tables.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/lispref/hash-tables.texi Mon Aug 13 11:07:10 2007 +0200 @@ -7,8 +7,8 @@ @chapter Hash Tables @cindex hash table -@defun hashtablep object -This function returns non-@code{nil} if @var{object} is a hash table. +@defun hash-table-p object +This function returns @code{t} if @var{object} is a hash table, else @code{nil}. @end defun @menu @@ -23,77 +23,162 @@ @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. +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}. -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 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. -(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.) +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}. -@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}. +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. -Note that currently, @code{eq} and @code{eql} are the same. This will -change when bignums are implemented. +A key-weak hash table is similar to a fully-weak hash table except that +a key-value pair will be removed only if the key remains unmarked +outside of weak hash tables. The pair will remain in the hash table if +the key is pointed to by something other than a weak hash table, even +if the value is not. + +A value-weak hash table is similar to a fully-weak hash table except +that a key-value pair will be removed only if the value remains +unmarked outside of weak hash tables. The pair will remain in the +hash table if the value is pointed to by something other than a weak +hash table, even if the key is not. + +Keyword @code{:rehash-size} must be a float greater than 1.0, and specifies +the factor by which to increase the size of the hash table when enlarging. + +Keyword @code{:rehash-threshold} must be a float between 0.0 and 1.0, +and specifies the load factor of the hash table which triggers enlarging. @end defun -@defun copy-hashtable old-table -This function makes a new hash table which contains the same keys and -values as the given table. The keys and values will not themselves be +@defun copy-hash-table hash-table +This function returns a new hash table which contains the same keys and +values as @var{hash-table}. The keys and values will not themselves be copied. @end defun -@defun hashtable-fullness table -This function returns number of entries in @var{table}. +@defun hash-table-count hash-table +This function returns the number of entries in @var{hash-table}. +@end defun + +@defun hash-table-size hash-table +This function returns the current number of slots in @var{hash-table}, +whether occupied or not. +@end defun + +@defun hash-table-type hash-table +This function returns the type of @var{hash-table}. +This can be one of @code{non-weak}, @code{weak}, @code{key-weak} or +@code{value-weak}. +@end defun + +@defun hash-table-test hash-table +This function returns the test function of @var{hash-table}. +This can be one of @code{eq}, @code{eql} or @code{equal}. +@end defun + +@defun hash-table-rehash-size hash-table +This function returns the current rehash size of @var{hash-table}. +This is a float greater than 1.0; the factor by which @var{hash-table} +is enlarged when the rehash threshold is exceeded. +@end defun + +@defun hash-table-rehash-threshold hash-table +This function returns the current rehash threshold of @var{hash-table}. +This is a float between 0.0 and 1.0; the maximum @dfn{load factor} of +@var{hash-table}, beyond which the @var{hash-table} is enlarged by rehashing. @end defun @node Working With Hash Tables @section Working With Hash Tables -@defun puthash key val table -This function hashes @var{key} to @var{val} in @var{table}. +@defun puthash key value hash-table +This function hashes @var{key} to @var{value} in @var{hash-table}. @end defun -@defun gethash key table &optional default -This function finds the hash value for @var{key} in @var{table}. If -there is no corresponding value, @var{default} is returned (defaults to -@code{nil}). +@defun gethash key hash-table &optional default +This function finds the hash value for @var{key} in @var{hash-table}. +If there is no entry for @var{key} in @var{hash-table}, @var{default} is +returned (which in turn defaults to @code{nil}). @end defun -@defun remhash key table -This function removes the hash value for @var{key} in @var{table}. +@defun remhash key hash-table +This function removes the entry for @var{key} from @var{hash-table}. +Does nothing if there is no entry for @var{key} in @var{hash-table}. @end defun -@defun clrhash table -This function flushes @var{table}. Afterwards, the hash table will -contain no entries. +@defun clrhash hash-table +This function removes all entries from @var{hash-table}, leaving it empty. @end defun -@defun maphash function table -This function maps @var{function} over entries in @var{table}, calling -it with two args, each key and value in the table. +@defun maphash function hash-table +This function maps @var{function} over entries in @var{hash-table}, +calling it with two args, each key and value in the hash table. + +@var{function} may not modify @var{hash-table}, with the one exception +that @var{function} may remhash or puthash the entry currently being +processed by @var{function}. @end defun @node Weak Hash Tables @@ -135,17 +220,5 @@ Also see @ref{Weak Lists}. -@defun make-weak-hashtable size &optional test-fun -This function makes a fully weak hash table of initial size @var{size}. -@var{test-fun} is as in @code{make-hashtable}. -@end defun - -@defun make-key-weak-hashtable size &optional test-fun -This function makes a key-weak hash table of initial size @var{size}. -@var{test-fun} is as in @code{make-hashtable}. -@end defun - -@defun make-value-weak-hashtable size &optional test-fun -This function makes a value-weak hash table of initial size @var{size}. -@var{test-fun} is as in @code{make-hashtable}. -@end defun +Weak hash tables are created by specifying the @code{:type} keyword to +@code{make-hash-table}. diff -r 76b7d63099ad -r 8626e4521993 man/lispref/macros.texi --- a/man/lispref/macros.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/lispref/macros.texi Mon Aug 13 11:07:10 2007 +0200 @@ -282,14 +282,14 @@ @end group @end example -@quotation -Before Emacs version 19.29, @samp{`} used a different syntax which -required an extra level of parentheses around the entire backquote -construct. Likewise, each @samp{,} or @samp{,@@} substitution required an -extra level of parentheses surrounding both the @samp{,} or @samp{,@@} -and the following expression. The old syntax required whitespace -between the @samp{`}, @samp{,} or @samp{,@@} and the following -expression. +@quotation +In older versions of Emacs (before XEmacs 19.12 or FSF Emacs version +19.29), @samp{`} used a different syntax which required an extra level +of parentheses around the entire backquote construct. Likewise, each +@samp{,} or @samp{,@@} substitution required an extra level of +parentheses surrounding both the @samp{,} or @samp{,@@} and the +following expression. The old syntax required whitespace between the +@samp{`}, @samp{,} or @samp{,@@} and the following expression. This syntax is still accepted, but no longer recommended except for compatibility with old Emacs versions. diff -r 76b7d63099ad -r 8626e4521993 man/lispref/objects.texi --- a/man/lispref/objects.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/lispref/objects.texi Mon Aug 13 11:07:10 2007 +0200 @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the XEmacs Lisp Reference Manual. -@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. +@c Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. @c See the file lispref.texi for copying conditions. @setfilename ../../info/objects.info @node Lisp Data Types, Numbers, Introduction, Top @@ -26,7 +26,7 @@ Each object belongs to one and only one primitive type. These types include @dfn{integer}, @dfn{character} (starting with XEmacs 20.0), @dfn{float}, @dfn{cons}, @dfn{symbol}, @dfn{string}, @dfn{vector}, -@dfn{bit-vector}, @dfn{subr}, @dfn{compiled-function}, @dfn{hashtable}, +@dfn{bit-vector}, @dfn{subr}, @dfn{compiled-function}, @dfn{hash-table}, @dfn{range-table}, @dfn{char-table}, @dfn{weak-list}, and several special types, such as @dfn{buffer}, that are related to editing. (@xref{Editing Types}.) @@ -173,7 +173,7 @@ @item glyph @item -hashtable +hash-table @item image-instance @item @@ -407,7 +407,7 @@ The usual read syntax for alphanumeric characters is a question mark followed by the character; thus, @samp{?A} for the character @kbd{A}, @samp{?B} for the character @kbd{B}, and @samp{?a} for the -character @kbd{a}. +character @kbd{a}. For example: @@ -1051,8 +1051,8 @@ in documentation strings, but the newline is \ ignored if escaped." - @result{} "It is useful to include newlines -in documentation strings, + @result{} "It is useful to include newlines +in documentation strings, but the newline is ignored if escaped." @end example @@ -1253,17 +1253,22 @@ that using an association list, when there are a large number of elements in the table). - Hash tables have no read syntax. They print in hash notation (The -``hash'' in ``hash notation'' has nothing to do with the ``hash'' in -``hash table''), giving the number of elements, total space allocated -for elements, and a unique number assigned at the time the hash table -was created. (Hash tables automatically resize as necessary so there -is no danger of running out of space for elements.) +Hash tables have a special read syntax beginning with +@samp{#s(hash-table} (this is an example of @dfn{structure} read +syntax. This notation is also used for printing when +@code{print-readably} is @code{t}. + +Otherwise they print in hash notation (The ``hash'' in ``hash notation'' +has nothing to do with the ``hash'' in ``hash table''), giving the +number of elements, total space allocated for elements, and a unique +number assigned at the time the hash table was created. (Hash tables +automatically resize as necessary so there is no danger of running out +of space for elements.) @example @group -(make-hashtable 50) - @result{} # +(make-hash-table :size 50) + @result{} # @end group @end example @@ -1983,8 +1988,8 @@ @item glyphp @xref{Glyphs, glyphp}. -@item hashtablep -@xref{Hash Tables, hashtablep}. +@item hash-table-p +@xref{Hash Tables, hash-table-p}. @item icon-glyph-p @xref{Glyph Types, icon-glyph-p}. @@ -2153,7 +2158,7 @@ @code{coding-system}, @code{cons}, @code{color-instance}, @code{compiled-function}, @code{console}, @code{database}, @code{device}, @code{event}, @code{extent}, @code{face}, @code{float}, -@code{font-instance}, @code{frame}, @code{glyph}, @code{hashtable}, +@code{font-instance}, @code{frame}, @code{glyph}, @code{hash-table}, @code{image-instance}, @code{integer}, @code{keymap}, @code{marker}, @code{process}, @code{range-table}, @code{specifier}, @code{string}, @code{subr}, @code{subwindow}, @code{symbol}, @code{toolbar-button}, diff -r 76b7d63099ad -r 8626e4521993 man/widget.texi --- a/man/widget.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/widget.texi Mon Aug 13 11:07:10 2007 +0200 @@ -670,7 +670,7 @@ TYPE ::= (info-link [KEYWORD ARGUMENT]... ADDRESS) @end example -When this link is invoked, the build-in info browser is started on +When this link is invoked, the built-in info browser is started on @var{address}. @node push-button, editable-field, info-link, Basic Types diff -r 76b7d63099ad -r 8626e4521993 man/xemacs-faq.texi --- a/man/xemacs-faq.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/xemacs-faq.texi Mon Aug 13 11:07:10 2007 +0200 @@ -7,7 +7,7 @@ @finalout @titlepage @title XEmacs FAQ -@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 1998/06/30 06:35:33 $ +@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 1998/12/05 16:55:03 $ @sp 1 @author Tony Rossini @author Ben Wing @@ -64,7 +64,7 @@ @item If you do not have makeinfo installed, you may @uref{xemacs-faq.info, download the faq} in info format, and install it in @file{/info/}. For example in +library directory>/info/}. For example in @file{/usr/local/lib/xemacs-20.4/info/}. @end itemize @@ -2727,7 +2727,7 @@ variables. Instead, use feature-tests, such as @code{featurep}, @code{boundp}, -@code{fboundp}, or even simple behavioural tests, eg.: +@code{fboundp}, or even simple behavioral tests, eg.: @lisp (defvar foo-old-losing-code-p diff -r 76b7d63099ad -r 8626e4521993 man/xemacs/custom.texi --- a/man/xemacs/custom.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/xemacs/custom.texi Mon Aug 13 11:07:10 2007 +0200 @@ -2481,7 +2481,7 @@ @node Menubar Resources @subsection Menubar Resources -As the menubar is implemented as a widget which is not a part of XEacs +As the menubar is implemented as a widget which is not a part of XEmacs proper, it does not use the fac" mechanism for specifying fonts and colors: It uses whatever resources are appropriate to the type of widget which is used to implement it. diff -r 76b7d63099ad -r 8626e4521993 man/xemacs/startup.texi --- a/man/xemacs/startup.texi Mon Aug 13 11:06:08 2007 +0200 +++ b/man/xemacs/startup.texi Mon Aug 13 11:07:10 2007 +0200 @@ -22,15 +22,15 @@ constitutes the "XEmacs installation": XEmacs may be run from the compilation directory, it may be installed into arbitrary directories, spread over several directories unrelated to each other. Moreover, it -may subsequently moved to a different place. (This last case is not as -uncommon as it sounds. Binary kits work this way.) Consequently, +may subsequently be moved to a different place. (This last case is not +as uncommon as it sounds. Binary kits work this way.) Consequently, XEmacs has quite complex procedures in place to find directories, no matter where they may be hidden. XEmacs will always respect directory options passed to @code{configure}. However, if it cannot locate a directory at the configured place, it will initiate a search for the directory in any of a number of -@dfn{hierachies} rooted under a directory which XEmacs assumes contain +@dfn{hierarchies} rooted under a directory which XEmacs assumes contain parts of the XEmacs installation; it may locate several such hierarchies and search across them. (Typically, there are just one or two hierarchies: the hierarchy where XEmacs was or will be installed, and diff -r 76b7d63099ad -r 8626e4521993 nt/ChangeLog --- a/nt/ChangeLog Mon Aug 13 11:06:08 2007 +0200 +++ b/nt/ChangeLog Mon Aug 13 11:07:10 2007 +0200 @@ -1,3 +1,7 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff -r 76b7d63099ad -r 8626e4521993 src/ChangeLog --- a/src/ChangeLog Mon Aug 13 11:06:08 2007 +0200 +++ b/src/ChangeLog Mon Aug 13 11:07:10 2007 +0200 @@ -1,3 +1,705 @@ +1998-12-05 XEmacs Build Bot + + * XEmacs 21.2.5 is released + +1998-11-30 Martin Buchholz + + * xselect.c (receive_incremental_selection): + * xselect.c (x_get_window_property): + * xmu.c (XmuReadBitmapDataFromFile): + * xmu.c (XmuCursorNameToIndex): + * xgccache.c (describe_gc_cache): + * xgccache.c (gc_cache_lookup): + * xgccache.c (free_gc_cache): + * xgccache.c (make_gc_cache): + * window.h: + * window.c (map_windows_1): + * window.c (Fother_window_for_scrolling): + * window.c (window_scroll): + * window.c (change_window_height): + * window.c (Fsplit_window): + * window.c (window_left_gutter_width): + * window.c (window_modeline_height): + * window.c (invalidate_vertical_divider_cache_in_window): + * window.c (window_needs_vertical_divider_1): + * window.c (update_mirror_internal): + * window.c (SET_LAST_FACECHANGE): + * widget.c (Fwidget_plist_member): + * unexec.c (copy_text_and_data): + * unexcw.c (copy_executable_and_dump_data_section): + * tooltalk.doc: + * tooltalk.c (struct Lisp_Tooltalk_Pattern): + * tooltalk.c (struct Lisp_Tooltalk_Message): + * toolbar.h (struct toolbar_button): + * toolbar.c (default_toolbar_visible_p_changed_in_window): + * toolbar.c (recompute_overlaying_specifier): + * toolbar.c (toolbar_validate): + * toolbar.c (toolbar_button_at_pixpos): + * toolbar.c (get_toolbar_coords): + * toolbar.c (update_frame_toolbars): + * toolbar-x.c: + * toolbar-msw.c (mswindows_handle_toolbar_wm_command): + * toolbar-msw.c (mswindows_find_toolbar_pos): + * toolbar-msw.c (mswindows_output_toolbar): + * toolbar-msw.c (mswindows_clear_toolbar): + * toolbar-msw.c: + * systty.h: + * syssignal.h: + * sysproc.h: + * sysfile.h: + * sysdll.c: + * sysdep.h: + * sysdep.c (rmdir): + * sysdep.c (sys_fopen): + * sysdep.c (sys_open): + * sysdep.c (tty_init_sys_modes_on_device): + * sysdep.c (get_eof_char): + * sysdep.c (child_setup_tty): + * sysdep.c (set_descriptor_non_blocking): + * syntax.h: + * syntax.c (scan_words): + * syntax.c: + * symsinit.h: + * symeval.h (struct symbol_value_varalias): + * symeval.h (struct symbol_value_forward): + * symbols.c (syms_of_symbols): + * symbols.c (init_symbols_once_early): + * symbols.c (Fbuilt_in_variable_type): + * symbols.c (Fsymbol_value_in_buffer): + * symbols.c (default_value): + * symbols.c (Fset): + * symbols.c (find_symbol_value_quickly): + * symbols.c (store_symval_forwarding): + * symbols.c (set_default_console_slot_variable): + * symbols.c (set_default_buffer_slot_variable): + * symbols.c (verify_ok_for_buffer_local): + * symbols.c (symbol_is_constant): + * symbols.c (oblookup): + * symbols.c (Funintern): + * symbols.c (Fintern): + * symbols.c (check_obarray): + * sunplay.c: + * specifier.h (struct specifier_methods): + * specifier.h: + * specifier.c (specifier_instance): + * specifier.c (specifier_instance_from_inst_list): + * specifier.c (decode_locale_type): + * specifier.c (specifier_equal): + * specifier.c (finalize_specifier): + * specifier.c (prune_specifiers): + * specifier.c (kill_specifier_buffer_locals): + * sound.c (init_native_sound): + * sound.c: + * signal.c (alarm): + * search.c (Fmatch_data): + * search.c (match_limit): + * search.c (Freplace_match): + * search.c (skip_chars): + * search.c (scan_buffer): + * search.c: + * scrollbar.c (specifier_vars_of_scrollbar): + * scrollbar.c (Fscrollbar_set_hscroll): + * scrollbar.c (vertical_scrollbar_changed_in_window): + * scrollbar.c (release_window_mirror_scrollbars): + * scrollbar.c (free_scrollbar_instance): + * scrollbar-x.c: + * scrollbar-msw.c: + * s/msdos.h (O_BINARY): + * s/linux.h: + * s/freebsd.h (LIBS_TERMCAP): + * regex.c (re_match_2_internal): + * regex.c (compile_extended_range): + * regex.c (POP_FAILURE_POINT): + * regex.c (PUSH_FAILURE_POINT): + * redisplay.h (RESET_CHANGED_SET_FLAGS): + * redisplay.h: + * redisplay.h (struct display_line): + * redisplay.h (struct rune): + * redisplay.c (vars_of_redisplay): + * redisplay.c (redisplay_variable_changed): + * redisplay.c (UPDATE_CACHE_RETURN): + * redisplay.c (validate_line_start_cache): + * redisplay.c (mark_redisplay_structs): + * redisplay.c (mark_glyph_block_dynarr): + * redisplay.c (window_line_number): + * redisplay.c (redisplay_frame): + * redisplay.c (redisplay_window): + * redisplay.c (generate_modeline): + * redisplay.c (create_right_glyph_block): + * redisplay.c (create_left_glyph_block): + * redisplay.c (create_text_block): + * redisplay.c: + * redisplay-x.c (x_output_hline): + * redisplay-x.c (x_output_vertical_divider): + * redisplay-tty.c (tty_output_display_block): + * redisplay-output.c (output_display_line): + * redisplay-output.c: + * redisplay-msw.c (mswindows_output_vertical_divider): + * redisplay-msw.c (mswindows_ring_bell): + * redisplay-msw.c (mswindows_output_cursor): + * redisplay-msw.c: + * rangetab.c: + * ralloc.c: + * puresize.h (RAW_PURESIZE): + * profile.c (syms_of_profile): + * profile.c (Fstart_profiling): + * profile.c (sigprof_handler): + * profile.c: + * procimpl.h: + * process.c (vars_of_process): + * process.c (read_process_output): + * process.c (get_process): + * process.c: + * process-unix.c (unix_open_multicast_group): + * process-unix.c (unix_get_tty_name): + * process-unix.c (unix_send_process): + * process-unix.c (unix_reap_exited_processes): + * process-unix.c (unix_create_process): + * process-unix.c (unix_init_process_io_handles): + * process-unix.c (allocate_pty): + * process-unix.c: + * process-nt.c (nt_open_network_stream): + * process-nt.c (nt_update_status_if_terminated): + * process-nt.c (nt_finalize_process_data): + * process-nt.c: + * print.c (debug_short_backtrace): + * print.c (debug_backtrace): + * print.c (print_symbol): + * print.c (print_internal): + * print.c (print_cons): + * print.c (Fwrite_char): + * print.c (print_prepare): + * print.c (canonicalize_printcharfun): + * print.c (output_string): + * print.c: + * opaque.h: + * opaque.c (allocate_managed_opaque): + * opaque.c: + * offix.c (DndSetData): + * objects.c (face_boolean_create): + * objects.c (font_instantiate): + * objects.c (font_create): + * objects.c (color_create): + * objects.c (finalize_font_instance): + * objects.c (finalize_color_instance): + * objects.c: + * objects-x.c (x_font_instance_truename): + * objects-x.c: + * objects-x.c (x_initialize_font_instance): + * objects-x.c (allocate_nearest_color): + * objects-tty.c (tty_initialize_font_instance): + * objects-tty.c (tty_initialize_color_instance): + * objects-msw.c (mswindows_initialize_color_instance): + * ntproc.c (syms_of_ntproc): + * ntproc.c (Fwin32_set_process_priority): + * ntproc.c (sys_spawnve): + * ntproc.c: + * ntheap.c (get_data_end): + * nt.c (period): + * nt.c: + * nt.c (stat): + * nt.c (generate_inode_val): + * nt.c (sys_rename): + * nas.c: + * mule-wnnfns.c (Fwnn_hinsi_number): + * mule-wnnfns.c (Fwnn_yuragi): + * mule-wnnfns.c (Fwnn_common_learn): + * mule-wnnfns.c (Fwnn_suffix_learn): + * mule-wnnfns.c (Fwnn_prefix_learn): + * mule-wnnfns.c (Fwnn_okuri_learn): + * mule-wnnfns.c (Fwnn_complex_conv): + * mule-wnnfns.c (Fwnn_last_is_first): + * mule-wnnfns.c (Fwnn_bmodify_dict_add): + * mule-wnnfns.c (Fwnn_notrans_dict_add): + * mule-wnnfns.c (Fwnn_fiusr_dict_add): + * mule-wnnfns.c (Fwnn_fisys_dict_add): + * mule-wnnfns.c (Fwnn_hinsi_list): + * mule-wnnfns.c (Fwnn_fuzokugo_set): + * mule-wnnfns.c (Fwnn_dict_search): + * mule-wnnfns.c (Fwnn_word_toroku): + * mule-wnnfns.c (Fwnn_hindo_update): + * mule-wnnfns.c (Fwnn_bunsetu_henkou): + * mule-wnnfns.c (Fwnn_kakutei): + * mule-wnnfns.c (Fwnn_begin_henkan): + * mule-wnnfns.c (Fwnn_dict_comment): + * mule-wnnfns.c (Fwnn_dict_add): + * mule-wnnfns.c (Fwnn_open): + * mule-mcpath.c (mc_getcwd): + * mule-coding.c (vars_of_mule_coding): + * mule-coding.c (convert_to_external_format): + * mule-coding.c (encoding_marker): + * mule-coding.c (decoding_marker): + * mule-coding.c (Fcopy_coding_system): + * mule-coding.c (Fmake_coding_system): + * mule-coding.c (Fcoding_system_list): + * mule-coding.c (Ffind_coding_system): + * mule-coding.c (symbol_to_eol_type): + * mule-coding.c: + * mule-charset.c (complex_vars_of_mule_charset): + * mule-charset.c (vars_of_mule_charset): + * mule-charset.c (Fset_charset_ccl_program): + * mule-charset.c (struct charset_list_closure): + * mule-charset.c (Ffind_charset): + * mule-charset.c (make_charset): + * mule-charset.c (non_ascii_valid_char_p): + * mule-charset.c: + * mule-ccl.c (ccl_driver): + * mule-canna.c (c2mu): + * mule-canna.c (Fcanna_henkan_begin): + * mule-canna.c (Fcanna_parse): + * mule-canna.c (Fcanna_store_yomi): + * mule-canna.c (Fcanna_touroku_string): + * mule-canna.c (Fcanna_initialize): + * minibuf.c: + * menubar.c (menu_parse_submenu_keywords): + * menubar-x.c (make_dummy_xbutton_event): + * menubar-x.c (set_frame_menubar): + * menubar-x.c (menu_item_descriptor_to_widget_value_1): + * menubar-x.c: + * menubar-msw.h: + * menubar-msw.c (mswindows_popup_menu): + * menubar-msw.c (mswindows_update_frame_menubars): + * menubar-msw.c (mswindows_handle_wm_command): + * menubar-msw.c (unsafe_handle_wm_initmenu_1): + * menubar-msw.c (unsafe_handle_wm_initmenupopup_1): + * menubar-msw.c (update_frame_menubar_maybe): + * menubar-msw.c (populate_or_checksum_helper): + * menubar-msw.c (empty_menu): + * menubar-msw.c: + * md5.c: + * marker.c (set_marker_internal): + * marker.c (print_marker): + * malloc.c: + * make-src-depend: + * lstream.c (lisp_buffer_rewinder): + * lstream.c (mark_lstream): + * lrecord.h: + * lrecord.h (struct lrecord_header): + * lread.c (readevalloop): + * lread.c (locate_file): + * lread.c (locate_file_in_directory): + * lread.c (Flocate_file): + * lread.c (load_force_doc_string_unwind): + * lread.c (ebolify_bytecode_constants): + * lread.c: + * lisp.h: + * lisp-union.h: + * lisp-disunion.h: + * linuxplay.c (linux_play_data_or_file): + * linuxplay.c (audio_init): + * line-number.c: + * keymap.h: + * keymap.c (describe_map): + * keymap.c (describe_map_mapper): + * keymap.c (Fdescribe_bindings_internal): + * keymap.c (Fsingle_key_description): + * keymap.c (map_keymap_sorted): + * keymap.c (get_relevant_keymaps): + * keymap.c (Flookup_key): + * keymap.c (raw_lookup_key_mapper): + * keymap.c (Fdefine_key): + * keymap.c (Fevent_matches_key_specifier_p): + * keymap.c (key_desc_list_to_event): + * keymap.c (define_key_parser): + * keymap.c (define_key_check_and_coerce_keysym): + * keymap.c (keymap_submaps): + * keymap.c (keymap_store_internal): + * keymap.c (keymap_delete_inverse_internal): + * keymap.c (keymap_store_inverse_internal): + * keymap.c (print_keymap): + * keymap.c (Lisp_Keymap): + * keymap.c: + * intl.c: + * insdel.c (convert_bufbyte_string_into_emchar_dynarr): + * insdel.c (make_gap): + * input-method-xlib.c (get_XIM_input): + * input-method-xlib.c (XIM_init_frame): + * imgproc.c: + * hash.h: + * hash.c: + * gui.c: + * gui-x.c (button_item_to_widget_value): + * gui-x.c (popup_selection_callback): + * glyphs.h (struct image_instantiator_methods): + * glyphs.c (mark_glyph_cachels): + * glyphs.c (Fglyph_type): + * glyphs.c (image_instantiate): + * glyphs.c (image_create): + * glyphs.c (make_image_instance_1): + * glyphs.c (finalize_image_instance): + * glyphs.c: + * glyphs-x.c (finalize_subwindow): + * glyphs-x.c (xface_validate): + * glyphs-x.c (x_locate_pixmap_file): + * glyphs-x.c (convert_EImage_to_XImage): + * glyphs-msw.c: + * glyphs-msw.c (mswindows_resource_instantiate): + * glyphs-msw.c (xpm_to_eimage): + * glyphs-msw.c (convert_EImage_to_DIBitmap): + * glyphs-eimage.c (tiff_instantiate): + * glyphs-eimage.c (png_instantiate): + * glyphs-eimage.c (struct png_error_struct): + * glyphs-eimage.c (gif_memory_storage): + * glyphs-eimage.c: + * gifrlib.h: + * getloadavg.c (getloadavg): + * getloadavg.c: + * gdbinit: + * free-hook.c (log_gcpro): + * free-hook.c (check_malloc): + * free-hook.c (check_free): + * free-hook.c (ROUND_UP_TO_PAGE): + * free-hook.c: + * frame.h (struct frame): + * frame.h: + * frame.c (change_frame_size_1): + * frame.c (allocate_frame_core): + * frame.c: + * frame-x.c (x_focus_on_frame): + * frame-x.c (x_init_frame_2): + * frame-x.c (x_popup_frame): + * frame-x.c (xemacs_XtPopup): + * frame-x.c: + * frame-x.c (Foffix_start_drag_internal): + * frame-x.c (x_cde_destroy_callback): + * frame-x.c (x_wm_hack_wm_protocols): + * frame-tty.c (tty_frame_visible_p): + * frame-msw.c (mswindows_make_frame_invisible): + * frame-msw.c (mswindows_after_init_frame): + * frame-msw.c (mswindows_init_frame_1): + * fns.c (syms_of_fns): + * fns.c (Fbase64_decode_string): + * fns.c (Fnconc): + * fns.c (Ffillarray): + * fns.c (Fobject_plist): + * fns.c (Fget): + * fns.c (Fcanonicalize_lax_plist): + * fns.c (Fcanonicalize_plist): + * fns.c (Fplist_remprop): + * fns.c (Fplist_get): + * fns.c (advance_plist_pointers): + * fns.c (internal_plist_put): + * fns.c (Fnreverse): + * fns.c (Fremassq): + * fns.c (Felt): + * fns.c (Fsubstring): + * fns.c (Fbvconcat): + * fns.c (Flength): + * fns.c (length_with_bytecode_hack): + * fns.c (print_bit_vector): + * fns.c: + * floatfns.c (Ffloor): + * floatfns.c: + * floatfns.c (in_float_error): + * fileio.c (Ffile_modes): + * fileio.c (Fexpand_file_name): + * fileio.c (Fmake_temp_name): + * fileio.c (Ffile_name_nondirectory): + * fileio.c (Ffile_name_directory): + * file-coding.h: + * file-coding.c (vars_of_mule_coding): + * file-coding.c (convert_to_external_format): + * file-coding.c (encoding_marker): + * file-coding.c (decoding_marker): + * file-coding.c (Fcopy_coding_system): + * file-coding.c (Fmake_coding_system): + * file-coding.c (struct coding_system_list_closure): + * file-coding.c (Ffind_coding_system): + * file-coding.c (symbol_to_eol_type): + * file-coding.c: + * faces.h (struct face_cachel): + * faces.c (vars_of_faces): + * faces.c (face_property_was_changed): + * faces.c (mark_face_cachels): + * faces.c (temporary_faces_list): + * faces.c (struct face_list_closure): + * faces.c: + * extents.h (struct extent): + * extents.c (vars_of_extents): + * extents.c (struct copy_string_extents_1_arg): + * extents.c (add_string_extents_mapper): + * extents.c (Fextent_property): + * extents.c (Fset_extent_property): + * extents.c (symbol_to_glyph_layout): + * extents.c (properties_equal): + * extents.c (print_extent): + * extents.c (print_extent_1): + * extents.c (extent_in_region_p): + * extents.c (gap_array_make_gap): + * extents.c: + * events.h (struct Lisp_Event): + * events.h: + * events.c (Fevent_properties): + * events.c (format_event_object): + * events.c (Fmake_event): + * events.c (event_equal): + * events.c (print_event): + * events.c (mark_event): + * event-stream.c ((read-char) + * event-stream.c (vars_of_event_stream): + * event-stream.c (syms_of_event_stream): + * event-stream.c (Fset_recent_keys_ring_size): + * event-stream.c (Fsit_for): + * event-stream.c (Fnext_event): + * event-stream.c (execute_help_form): + * event-stream.c (maybe_kbd_translate): + * event-stream.c: + * event-msw.c (vars_of_event_mswindows): + * event-msw.c (mswindows_wnd_proc): + * event-msw.c (mswindows_need_event): + * event-msw.c (mswindows_drain_windows_queue): + * event-msw.c (mswindows_pump_outstanding_events): + * event-msw.c: + * event-msw.c (slurp_thread): + * event-msw.c (struct ntpipe_slurp_stream): + * event-msw.c (HANDLE_TO_USID): + * event-Xt.c (emacs_Xt_handle_magic_event): + * event-Xt.c (x_event_to_emacs_event): + * event-Xt.c (x_reset_modifier_mapping): + * event-Xt.c (x_reset_key_mapping): + * event-Xt.c: + * eval.c (syms_of_eval): + * eval.c (warn_when_safe): + * eval.c (warn_when_safe_lispobj): + * eval.c (Fbacktrace_frame): + * eval.c (Fbacktrace): + * eval.c (top_level_set): + * eval.c (unbind_to_hairy): + * eval.c (specbind_magic): + * eval.c (specbind_unwind_wasnt_local): + * eval.c (call2_trapping_errors): + * eval.c (call1_trapping_errors): + * eval.c (catch_them_squirmers_call2): + * eval.c (call0_trapping_errors): + * eval.c (run_hook_trapping_errors): + * eval.c (catch_them_squirmers_eval_in_buffer): + * eval.c (call4_in_buffer): + * eval.c (call3_in_buffer): + * eval.c (call2_in_buffer): + * eval.c (call1_in_buffer): + * eval.c (call0_in_buffer): + * eval.c (run_hook): + * eval.c (run_hook_with_args_in_buffer): + * eval.c (Fapply): + * eval.c (Feval): + * eval.c (do_autoload): + * eval.c (un_autoload): + * eval.c (Fautoload): + * eval.c (Finteractive_p): + * eval.c (Fcommand_execute): + * eval.c (signal_quit): + * eval.c (call_with_suspended_errors): + * eval.c (signal_error): + * eval.c (return_from_signal): + * eval.c (Fcall_with_condition_handler): + * eval.c (run_condition_case_handlers): + * eval.c (condition_case_1): + * eval.c (Funwind_protect): + * eval.c (unwind_to_catch): + * eval.c (internal_catch): + * eval.c (Fmacroexpand_internal): + * eval.c (Fuser_variable_p): + * eval.c (Fdefconst): + * eval.c (Fdefvar): + * eval.c (Ffunction): + * eval.c (signal_call_debugger): + * eval.c (call_debugger): + * eval.c: + * emacs.c (main): + * emacs.c (sort_args): + * emacs.c (main_1): + * elhash.h: + * elhash.c: + * editfns.c (Fencode_time): + * editfns.c (Fdecode_time): + * editfns.c (Fuser_full_name): + * editfns.c: + * editfns.c (save_excursion_restore): + * ecrt0.c: + * dynarr.c: + * doprnt.c (emacs_doprnt_1): + * doc.c (verify_doc_mapper): + * doc.c (Fsnarf_documentation): + * doc.c (Fdocumentation): + * dll.c: + * dired.c (user_name_completion): + * dired.c (Fdirectory_files): + * dialog-x.c: + * dialog-msw.c: + * dgif_lib.c (FreeSavedImages): + * dgif_lib.c (DGifGetImageDesc): + * device.h: + * device.h (struct device): + * device.c (Fselect_device): + * device.c (allocate_device): + * device.c: + * device-x.c (Fx_keysym_on_keyboard_p): + * device-x.c (Fx_valid_keysym_name_p): + * device-x.c (x_IO_error_handler): + * device-x.c (x_delete_device): + * device-x.c (x_finish_init_device): + * device-x.c (x_init_device): + * device-x.c: + * device-msw.c (mswindows_init_device): + * dbxrc: + * database.c (vars_of_database): + * database.c (Fput_database): + * database.c (Fopen_database): + * database.c (berkdb_remove): + * database.c (berkdb_put): + * database.c (Fdatabasep): + * database.c (print_database): + * database.c: + * data.c (vars_of_data): + * data.c (syms_of_data): + * data.c (init_errors_once_early): + * data.c (prune_weak_lists): + * data.c (finish_marking_weak_lists): + * data.c (print_weak_list): + * data.c (Fmod): + * data.c (Fstring_to_number): + * data.c (Fnumber_to_string): + * data.c (Findirect_function): + * data.c (Fsetcdr): + * data.c (Ffloatp): + * data.c (Fsubr_interactive): + * data.c (Farrayp): + * data.c (Fkeywordp): + * data.c (Fnull): + * data.c: + * console.h (CONSOLE_NAME): + * console.h: + * console.c (vars_of_console): + * console.c (Fselect_console): + * console.c: + * console-x.h (DEVICE_X_COLORMAP): + * console-x.h (struct x_device): + * console-x.c (x_device_to_console_connection): + * console-tty.h (CONSOLE_TTY_FINAL_CURSOR_Y): + * console-tty.c (tty_init_console): + * console-tty.c: + * console-msw.h (struct mswindows_frame): + * conslots.h: + * config.h.in: + * cmds.c (internal_self_insert): + * cmds.c (Fforward_line): + * cmds.c (Fforward_char): + * cmds.c: + * cmdloop.c: + * chartab.c (mark_char_table_entry): + * chartab.c: + * casefiddle.c (casify_word): + * callproc.c (child_setup): + * callproc.c (Fcall_process_internal): + * callproc.c: + * callint.c (Fcall_interactively): + * bytecode.h: + * bytecode.c (execute_rare_opcode): + * bytecode.c (execute_optimized_program): + * bytecode.c: + * bufslots.h: + * buffer.h (BUFFER_REALLOC): + * buffer.h (GET_CHARPTR_INT_DATA_ALLOCA): + * buffer.h (GET_CHARPTR_EXT_DATA_ALLOCA): + * buffer.h: + * buffer.h (MAP_INDIRECT_BUFFERS): + * buffer.h (CHECK_LIVE_BUFFER): + * buffer.c (init_initial_directory): + * buffer.c (complex_vars_of_buffer): + * buffer.c (vars_of_buffer): + * buffer.c (finish_init_buffer): + * buffer.c (Fget_file_buffer): + * buffer.c (Fbuffer_list): + * buffer.c (mark_buffer): + * balloon_help.c (balloon_help_move_to_pointer): + * balloon_help.c (show_help): + * balloon_help.c: + * backtrace.h: + * alloc.c (garbage_collect_1): + * alloc.c (sweep_strings): + * alloc.c (sweep_compiled_functions): + * alloc.c (sweep_bit_vectors_1): + * alloc.c (sweep_vectors_1): + * alloc.c (sweep_lcrecords_1): + * alloc.c (tick_lcrecord_stats): + * alloc.c (pure_string_sizeof): + * alloc.c (mark_conses_in_list): + * alloc.c (mark_object): + * alloc.c (report_pure_usage): + * alloc.c (make_pure_float): + * alloc.c (make_pure_string): + * alloc.c (free_managed_lcrecord): + * alloc.c (mark_string): + * alloc.c (noseeum_make_marker): + * alloc.c (allocate_event): + * alloc.c (Fbit_vector): + * alloc.c (Fvector): + * alloc.c (make_float): + * alloc.c (Fmake_list): + * alloc.c (Flist): + * alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC): + * alloc.c (PUT_FIXED_TYPE_ON_FREE_LIST): + * alloc.c (DECLARE_FIXED_TYPE_ALLOC): + * alloc.c (dbg_constants): + * alloc.c (gc_record_type_p): + * alloc.c (free_lcrecord): + * alloc.c (xmalloc): + * alloc.c (NOSEEUM_INCREMENT_CONS_COUNTER): + * abbrev.c: + * Makefile.in.in (mostlyclean): + * Makefile.in.in (external_client_xlib_objs_nonshared): + * Makefile.in.in (temacs_link_args): + * Makefile.in.in (release): + * Makefile.in.in (dnd_objs): + * Makefile.in.in (objs): + * Makefile.in.in (PROGNAME): + * EmacsShell.c: cast strings to (XtPointer) + * EmacsFrame.c: cast strings to (XtPointer) + - mega patch + - rewrite basic lisp functions for speed + - rewrite bytecode interpreter for speed + - rewrite list looping constructs for speed and safety using + tortoise/hare. + - use size_t where appropriate. + - new hashtable implementation + - cleanup implementation of opaques + - opaques can now be purecopy'ed + - move some cl functionality into C for speed. + - remove last remaining VMS support + - spelling fixes + - improve gdb/dbx debugger support + - move pure.c back into alloc.c for performance + - enable report_pure_usage() if --memory-usage-stats + - remove remnants of Energize support (EMACS_BTL, cadillac...) + - don't use symbols with leading `_' or embedded `__' + - globally cleanup duplicated semicolons `;;' + - I give in on %p vs %lx - we use printf("%lx",(long) p) + globally. + - globally replace O_NDELAY with O_NONBLOCK. + - globally replace CDISABLE with _POSIX_VDISABLE. + - use O_RDONLY and O_RDWR instead of magic `0' and `2'. + - define (and maybe use!) STDERR_FILENO and friends. + - add support for macros defined in C + - `when', `unless', `not' and `defalias' now defined in C, + so that they are universally available. + - rename defvar_mumble to defvar_magic + - rename RETURN__ to RETURN_SANS_WARNINGS + - use consistent style of initial caps in error messages + - implement last, butlast, nbutlast, copy-list in C. + - provide typedefs for all struct Lisp_foo types + - Lisp_Objects must be initialized to Qnil rather than 0. + - make sure XEmacs runs (slowly) with always_gc == 1; + - fast and safe LOOP_* macros + - change calls to XSETOBJ to XSETFOO + - replace calls to XSETINT by make_int() + - plug up memory leaks + - use style markobj (foo), not silly ((markobj) (foo)) + - use XFLOAT_DATA (obj) instead of float_data (XFLOAT (obj)) + +1998-12-02 P. E. Jareth Hein + + * unexec.c: Changed a #ifndef statement to fix XEmacs on BSDI 3.0 + 1998-11-28 SL Baur * XEmacs 21.2-beta4 is released. diff -r 76b7d63099ad -r 8626e4521993 src/EmacsFrame.c --- a/src/EmacsFrame.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/EmacsFrame.c Mon Aug 13 11:07:10 2007 +0200 @@ -40,7 +40,6 @@ #include "faces.h" #include "frame.h" #include "toolbar.h" -#include "redisplay.h" #include "window.h" static void EmacsFrameClassInitialize (void); @@ -115,9 +114,9 @@ sizeof (int), offset (right_toolbar_border_width), XtRImmediate, (XtPointer)-1}, {XtNtopToolBarShadowColor, XtCTopToolBarShadowColor, XtRPixel, sizeof(Pixel), - offset(top_toolbar_shadow_pixel), XtRString, "#000000"}, + offset(top_toolbar_shadow_pixel), XtRString, (XtPointer) "#000000"}, {XtNbottomToolBarShadowColor, XtCBottomToolBarShadowColor, XtRPixel, - sizeof(Pixel), offset(bottom_toolbar_shadow_pixel), XtRString, "#000000"}, + sizeof(Pixel), offset(bottom_toolbar_shadow_pixel), XtRString, (XtPointer) "#000000"}, {XtNbackgroundToolBarColor, XtCBackgroundToolBarColor, XtRPixel, sizeof(Pixel), offset(background_toolbar_pixel), XtRImmediate, (XtPointer)-1}, @@ -145,11 +144,11 @@ offset(font), XtRImmediate, (XtPointer)0 }, {XtNforeground, XtCForeground, XtRPixel, sizeof(Pixel), - offset(foreground_pixel), XtRString, "Black"}, + offset(foreground_pixel), XtRString, (XtPointer) "Black"}, {XtNbackground, XtCBackground, XtRPixel, sizeof(Pixel), - offset(background_pixel), XtRString, "Gray80"}, + offset(background_pixel), XtRString, (XtPointer) "Gray80"}, {XtNcursorColor, XtCForeground, XtRPixel, sizeof(Pixel), - offset(cursor_color), XtRString, "XtDefaultForeground"}, + offset(cursor_color), XtRString, (XtPointer) "XtDefaultForeground"}, {XtNbarCursor, XtCBarCursor, XtRBoolean, sizeof (Boolean), offset (bar_cursor), XtRImmediate, (XtPointer)0}, {XtNvisualBell, XtCVisualBell, XtRBoolean, sizeof (Boolean), @@ -411,7 +410,7 @@ f->internal_border_width = new->emacs_frame.internal_border_width; MARK_FRAME_SIZE_SLIPPED (f); } - + #ifdef HAVE_SCROLLBARS if (cur->emacs_frame.scrollbar_width != new->emacs_frame.scrollbar_width) @@ -625,7 +624,6 @@ EmacsFrame ew = (EmacsFrame) widget; int pixel_width, pixel_height; struct frame *f = ew->emacs_frame.frame; - Arg al [2]; if (columns < 3) columns = 3; /* no way buddy */ @@ -637,7 +635,10 @@ if (FRAME_X_TOP_LEVEL_FRAME_P (f)) x_wm_set_variable_size (FRAME_X_SHELL_WIDGET (f), columns, rows); - XtSetArg (al [0], XtNwidth, (Dimension) pixel_width); - XtSetArg (al [1], XtNheight, (Dimension) pixel_height); - XtSetValues ((Widget) ew, al, 2); + { + Arg al [2]; + XtSetArg (al [0], XtNwidth, pixel_width); + XtSetArg (al [1], XtNheight, pixel_height); + XtSetValues ((Widget) ew, al, countof (al)); + } } diff -r 76b7d63099ad -r 8626e4521993 src/EmacsShell.c --- a/src/EmacsShell.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/EmacsShell.c Mon Aug 13 11:07:10 2007 +0200 @@ -24,14 +24,12 @@ #include -#include +#include #include #include #include "xintrinsicp.h" #include #include -#include -#include #include "EmacsShell.h" #include "ExternalShell.h" @@ -140,17 +138,14 @@ void EmacsShellSmashIconicHint (Widget shell, int iconic_p) { - /* See comment in xfns.c about this */ - WMShellWidget wmshell; - int old, new; - if (! XtIsSubclass (shell, wmShellWidgetClass)) abort (); - wmshell = (WMShellWidget) shell; - old = (wmshell->wm.wm_hints.flags & StateHint - ? wmshell->wm.wm_hints.initial_state - : NormalState); - new = (iconic_p ? IconicState : NormalState); + /* See comment in frame-x.c about this */ + WMShellWidget wmshell = (WMShellWidget) shell; + assert (XtIsSubclass (shell, wmShellWidgetClass)); + /* old_state = (wmshell->wm.wm_hints.flags & StateHint + ? wmshell->wm.wm_hints.initial_state + : NormalState); */ wmshell->wm.wm_hints.flags |= StateHint; - wmshell->wm.wm_hints.initial_state = new; + wmshell->wm.wm_hints.initial_state = iconic_p ? IconicState : NormalState; } void diff -r 76b7d63099ad -r 8626e4521993 src/Makefile.in.in --- a/src/Makefile.in.in Mon Aug 13 11:06:08 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 11:07:10 2007 +0200 @@ -31,7 +31,13 @@ .SUFFIXES: .SUFFIXES: .c .h .o .i .s .dep +#ifdef USE_GNU_MAKE +RECURSIVE_MAKE=$(MAKE) +#else @SET_MAKE@ +RECURSIVE_MAKE=@RECURSIVE_MAKE@ +#endif + SHELL=/bin/sh RM = rm -f @@ -44,12 +50,11 @@ srcdir=@srcdir@ blddir=@blddir@ version=@version@ -CC=@CC@ +CC=@XEMACS_CC@ CPP=@CPP@ CFLAGS=@CFLAGS@ CPPFLAGS=@CPPFLAGS@ LDFLAGS=@LDFLAGS@ -RECURSIVE_MAKE=@RECURSIVE_MAKE@ c_switch_all=@c_switch_all@ ld_switch_all=@ld_switch_all@ @@ -173,7 +178,7 @@ $(gui_objs) hash.o imgproc.o indent.o insdel.o intl.o\ keymap.o $(RTC_patch_objs) line-number.o lread.o lstream.o\ macros.o marker.o md5.o minibuf.o objects.o opaque.o\ - print.o process.o profile.o pure.o\ + print.o process.o profile.o\ rangetab.o redisplay.o redisplay-output.o regex.o\ search.o $(sheap_obj) signal.o sound.o\ specifier.o strftime.o symbols.o syntax.o sysdep.o\ @@ -292,11 +297,11 @@ ## define otherobjs as list of object files that make-docfile ## should not be told about. -otherobjs = $(BTL_objs) lastfile.o $(mallocobjs) $(rallocobjs) $(X11_objs) +otherobjs = lastfile.o $(mallocobjs) $(rallocobjs) $(X11_objs) otherrtls = $(otherobjs:.o=.c.rtl) othersrcs = $(otherobjs:.o=.c) -LIBES = $(lwlib_libs) $(quantify_libs) $(malloclib) $(ld_libs_all) $(lib_gcc) +LIBES = $(lwlib_libs) $(malloclib) $(ld_libs_all) $(lib_gcc) #ifdef I18N3 mo_dir = ${etcdir} @@ -305,6 +310,9 @@ LOADPATH = EMACSBOOTSTRAPLOADPATH="${lispdir}:${blddir}" DUMPENV = $(LOADPATH) +temacs_loadup = $(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el +dump_temacs = ${temacs_loadup} dump +run_temacs = ${temacs_loadup} run-temacs release: temacs ${libsrc}DOC $(mo_file) ${other_files} #ifdef CANNOT_DUMP @@ -332,8 +340,8 @@ ${PROGNAME}: temacs ${libsrc}DOC $(mo_file) ${other_files} update-elc.stamp @$(RM) $@ && touch SATISFIED - -$(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el dump - @if test -f $@; then if test -f SATISFIED; then \ + -${dump_temacs} + @if test -f $@; then if test -f SATISFIED; then \ echo "Testing for Lisp shadows ..."; \ ./${PROGNAME} -batch -vanilla -f list-load-path-shadows; fi; \ $(RM) SATISFIED; exit 0; fi; \ @@ -342,8 +350,8 @@ fastdump: temacs @$(RM) ${PROGNAME} && touch SATISFIED - -$(DUMPENV) ./temacs -batch -l ${srcdir}/../lisp/loadup.el dump - @if test -f ${PROGNAME}; then if test -f SATISFIED; then \ + -${dumpp_temacs} + @if test -f ${PROGNAME}; then if test -f SATISFIED; then \ ./${PROGNAME} -batch -vanilla -f list-load-path-shadows; fi; \ $(RM) SATISFIED; exit 0; fi; \ if test -f SATISFIED; then $(RM) SATISFIED; exit 1; fi; @@ -441,22 +449,31 @@ .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. -## +## 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. -.PHONY : run-rtcmacs run-puremacs run-quantmacs - +## RTC is Sun WorkShop's Run Time Checking, integrated with dbx rtc_patch.o: rtc_patch_area -o $@ @@ -464,6 +481,7 @@ $(RM) temacs; $(RECURSIVE_MAKE) temacs RTC_patch_objs=rtc_patch.o mv temacs rtcmacs +.PHONY: run-rtcmacs run-rtcmacs: rtcmacs dbx -q -C -c \ 'dbxenv rtc_error_log_file_name /dev/fd/1; \ @@ -474,27 +492,32 @@ runargs -batch -l ${srcdir}/../lisp/loadup.el run-temacs -q; \ run' rtcmacs +## Purify, Quantify, PureCoverage are software quality products from +## Rational, formerly Pure Atria, formerly Pure Software. +## ## Purify -PURIFY_PROG=purify -PURIFY_FLAGS=-chain-length=32 -ignore-signals=SIGPOLL -threads=yes \ +PURIFY_PROG = purify +PURIFY_FLAGS = -chain-length=32 -ignore-signals=SIGPOLL -threads=yes \ -cache-dir=./purecache -always-use-cache-dir=yes -pointer-mask=0x0fffffff +PURIFY_LIBS = -lpthread puremacs: $(temacs_deps) - $(PURIFY_PROG) $(PURIFY_FLAGS) $(LD) $(temacs_link_args) -lpthread - -run-puremacs: puremacs - -$(DUMPENV) ./puremacs -batch -l ${srcdir}/../lisp/loadup.el run-temacs + $(PURIFY_PROG) $(PURIFY_FLAGS) $(LD) $(temacs_link_args) $(PURIFY_LIBS) + cp $@ temacs ## Quantify #ifdef QUANTIFY -quantify_prog = quantify -quantify_flags = -windows=no -record-data=no -quantify_includes = -I/local/include -quantify_libs = /local/lib/quantify_stubs.a +QUANTIFY_PROG = quantify +QUANTIFY_HOME = `$(QUANTIFY_PROG) -print-home-dir` +QUANTIFY_FLAGS = -cache-dir=./purecache -always-use-cache-dir=yes +cppflags += -I$(QUANTIFY_HOME) +temacs_link_args += $(QUANTIFY_HOME)/quantify_stubs.a quantmacs: $(temacs_deps) - $(quantify_prog) $(quantify_flags) $(LD) $(temacs_link_args) + $(QUANTIFY_PROG) $(QUANTIFY_FLAGS) $(LD) $(temacs_link_args) + cp $@ temacs #endif /* QUANTIFY */ + PURECOV_PROG=purecov covmacs: $(temacs_deps) $(PURECOV_PROG) $(LD) $(temacs_link_args) @@ -648,16 +671,6 @@ #endif /* HAVE_ALLOCA */ #endif /* ! defined (C_ALLOCA) */ -#ifdef EMACS_BTL -BTL_includes = -I$(BTL_dir) -BTL_compile = -DEMACS_BTL -D`lucid-arch` -I. $(BTL_includes) $(BTL_dir)/$(@:.o=.c) - -cadillac-btl.o cadillac-btl-process.o cadillac-btl-emacs.o: - $(CC) $(CFLAGS) -c $(BTL_compile) -cadillac-btl-asm.o: - $(CC) $(CFLAGS) -c $(BTL_compile) -#endif /* EMACS_BTL */ - #ifdef HAVE_NATIVE_SOUND sunplay.o: ${srcdir}/sunplay.c $(CC) -c $(sound_cflags) $(cflags) ${srcdir}/sunplay.c @@ -679,7 +692,7 @@ ## Do not use it on development directories! distclean: clean $(RM) config.h paths.h Emacs.ad.h \ - Makefile Makefile.in TAGS ${PROGNAME}.* + Makefile Makefile.in GNUmakefile TAGS ${PROGNAME}.* realclean: distclean versionclean: $(RM) ${PROGNAME} ${PROGNAME}.exe ${libsrc}DOC @@ -696,7 +709,9 @@ chmod -w $(SOURCES) ## Dependency processing using home-grown script, not makedepend +.PHONY: depend +FRC.depend: depend: FRC.depend - $(RM) ${srcdir}/depend depend.tmp - perl ${srcdir}/make-src-depend > depend.tmp - mv depend.tmp ${srcdir}/depend + cd ${srcdir} && $(RM) depend.tmp && \ + perl make-src-depend > depend.tmp && \ + $(RM) depend && mv depend.tmp depend diff -r 76b7d63099ad -r 8626e4521993 src/abbrev.c --- a/src/abbrev.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/abbrev.c Mon Aug 13 11:07:10 2007 +0200 @@ -172,7 +172,7 @@ It is an order of magnitude faster than the proper abbrev_match(), but then again, vi is an order of magnitude faster than Emacs. - This speed difference should be unnoticable, though. I have tested + This speed difference should be unnoticeable, though. I have tested the degenerated cases of thousands of abbrevs being defined, and abbrev_match() was still fast enough for normal operation. */ static struct Lisp_Symbol * diff -r 76b7d63099ad -r 8626e4521993 src/acldef.h --- a/src/acldef.h Mon Aug 13 11:06:08 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,65 +0,0 @@ -/* 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: FSF 19.30. */ - -/* Authorship: - - FSF: Original version; a long time ago. - No changes for XEmacs. - */ - -#define ACL$K_LENGTH 12 -#define ACL$C_LENGTH 12 -#define ACL$C_FILE 1 -#define ACL$C_DEVICE 2 -#define ACL$C_JOBCTL_QUEUE 3 -#define ACL$C_COMMON_EF_CLUSTER 4 -#define ACL$C_LOGICAL_NAME_TABLE 5 -#define ACL$C_PROCESS 6 -#define ACL$C_GROUP_GLOBAL_SECTION 7 -#define ACL$C_SYSTEM_GLOBAL_SECTION 8 -#define ACL$C_ADDACLENT 1 -#define ACL$C_DELACLENT 2 -#define ACL$C_MODACLENT 3 -#define ACL$C_FNDACLENT 4 -#define ACL$C_FNDACETYP 5 -#define ACL$C_DELETEACL 6 -#define ACL$C_READACL 7 -#define ACL$C_ACLLENGTH 8 -#define ACL$C_READACE 9 -#define ACL$C_RLOCK_ACL 10 -#define ACL$C_WLOCK_ACL 11 -#define ACL$C_UNLOCK_ACL 12 -#define ACL$S_ADDACLENT 255 -#define ACL$S_DELACLENT 255 -#define ACL$S_MODACLENT 255 -#define ACL$S_FNDACLENT 255 -#define ACL$S_FNDACETYP 255 -#define ACL$S_DELETEACL 255 -#define ACL$S_READACL 512 -#define ACL$S_ACLLENGTH 4 -#define ACL$S_READACE 255 -#define ACL$S_RLOCK_ACL 4 -#define ACL$S_WLOCK_ACL 4 -#define ACL$S_UNLOCK_ACL 4 -#define ACL$S_ACLDEF 16 -#define ACL$L_FLINK 0 -#define ACL$L_BLINK 4 -#define ACL$W_SIZE 8 -#define ACL$B_TYPE 10 -#define ACL$L_LIST 12 diff -r 76b7d63099ad -r 8626e4521993 src/alloc.c --- a/src/alloc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/alloc.c Mon Aug 13 11:07:10 2007 +0200 @@ -51,6 +51,7 @@ #include "extents.h" #include "frame.h" #include "glyphs.h" +#include "opaque.h" #include "redisplay.h" #include "specifier.h" #include "sysfile.h" @@ -74,11 +75,9 @@ /* Define this to see where all that space is going... */ /* But the length of the printout is obnoxious, so limit it to testers */ -/* If somebody wants to see this they can ask for it. -#ifdef DEBUG_XEMACS +#ifdef MEMORY_USAGE_STATS #define PURESTAT #endif -*/ /* Define this to use malloc/free with no freelist for all datatypes, the hope being that some debugging tools may help detect @@ -91,24 +90,13 @@ #include "puresize.h" #ifdef DEBUG_XEMACS -int debug_allocation; - -int debug_allocation_backtrace_length; +static int debug_allocation; +static int debug_allocation_backtrace_length; #endif /* Number of bytes of consing done since the last gc */ EMACS_INT consing_since_gc; -#ifdef EMACS_BTL -extern void cadillac_record_backtrace (); -#define INCREMENT_CONS_COUNTER_1(size) \ - do { \ - EMACS_INT __sz__ = ((EMACS_INT) (size)); \ - consing_since_gc += __sz__; \ - cadillac_record_backtrace (2, __sz__); \ - } while (0) -#else #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size)) -#endif /* EMACS_BTL */ #define debug_allocation_backtrace() \ do { \ @@ -141,14 +129,11 @@ INCREMENT_CONS_COUNTER_1 (size) #endif -#define DECREMENT_CONS_COUNTER(size) \ - do { \ - EMACS_INT __sz__ = ((EMACS_INT) (size)); \ - if (consing_since_gc >= __sz__) \ - consing_since_gc -= __sz__; \ - else \ - consing_since_gc = 0; \ - } while (0) +#define DECREMENT_CONS_COUNTER(size) do { \ + consing_since_gc -= (size); \ + if (consing_since_gc < 0) \ + consing_since_gc = 0; \ +} while (0) /* Number of bytes of consing since gc before another gc should be done. */ EMACS_INT gc_cons_threshold; @@ -195,6 +180,9 @@ extern void sheap_adjust_h(); #endif +/* Force linker to put it into data space! */ +EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0}; + #define PUREBEG ((char *) pure) #if 0 /* This is breathing_space in XEmacs */ @@ -213,7 +201,8 @@ ((char *) (ptr) >= PUREBEG && \ (char *) (ptr) < PUREBEG + get_PURESIZE()) -/* Non-zero if pure_bytes_used > get_PURESIZE(); accounts for excess purespace needs. */ +/* Non-zero if pure_bytes_used > get_PURESIZE(); + accounts for excess purespace needs. */ static size_t pure_lossage; #ifdef ERROR_CHECK_TYPECHECK @@ -262,9 +251,9 @@ #else /* PURESTAT */ -static int purecopying_for_bytecode; - -static size_t pure_sizeof (Lisp_Object /*, int recurse */); +static int purecopying_function_constants; + +static size_t pure_sizeof (Lisp_Object); /* Keep statistics on how much of what is in purespace */ static struct purestat @@ -276,9 +265,9 @@ purestat_cons = {0, 0, "cons cells"}, purestat_float = {0, 0, "float objects"}, purestat_string_pname = {0, 0, "symbol-name strings"}, - purestat_bytecode = {0, 0, "compiled-function objects"}, - purestat_string_bytecodes = {0, 0, "byte-code strings"}, - purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"}, + purestat_function = {0, 0, "compiled-function objects"}, + purestat_opaque_instructions = {0, 0, "compiled-function instructions"}, + purestat_vector_constants = {0, 0, "compiled-function constants vectors"}, purestat_string_interactive = {0, 0, "interactive strings"}, #ifdef I18N3 purestat_string_domain = {0, 0, "domain strings"}, @@ -290,27 +279,6 @@ purestat_string_all = {0, 0, "all strings"}, purestat_vector_all = {0, 0, "all vectors"}; -static struct purestat *purestats[] = -{ - &purestat_cons, - &purestat_float, - &purestat_string_pname, - &purestat_bytecode, - &purestat_string_bytecodes, - &purestat_vector_bytecode_constants, - &purestat_string_interactive, -#ifdef I18N3 - &purestat_string_domain, -#endif - &purestat_string_documentation, - &purestat_string_other_function, - &purestat_vector_other, - &purestat_string_other, - 0, - &purestat_string_all, - &purestat_vector_all -}; - static void bump_purestat (struct purestat *purestat, size_t nbytes) { @@ -318,13 +286,25 @@ purestat->nobjects += 1; purestat->nbytes += nbytes; } + +static void +print_purestat (struct purestat *purestat) +{ + char buf [100]; + sprintf(buf, "%s:", purestat->name); + message (" %-36s %5d %7d %2d%%", + buf, + purestat->nobjects, + purestat->nbytes, + (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5)); +} #endif /* PURESTAT */ /* Maximum amount of C stack to save when a GC happens. */ #ifndef MAX_SAVE_STACK -#define MAX_SAVE_STACK 16000 +#define MAX_SAVE_STACK 0 /* 16000 */ #endif /* Non-zero means ignore malloc warnings. Set during initialization. */ @@ -395,12 +375,19 @@ return val; } +static void * +xcalloc (size_t nelem, size_t elsize) +{ + void *val = (void *) calloc (nelem, elsize); + + if (!val && (nelem != 0)) memory_full (); + return val; +} + void * xmalloc_and_zero (size_t size) { - void *val = xmalloc (size); - memset (val, 0, size); - return val; + return xcalloc (size, sizeof (char)); } #ifdef xrealloc @@ -519,17 +506,15 @@ { struct lcrecord_header *lcheader; - if (size <= 0) abort (); +#ifdef ERROR_CHECK_GC if (implementation->static_size == 0) - { - if (!implementation->size_in_bytes_method) - abort (); - } - else if (implementation->static_size != size) - abort (); + assert (implementation->size_in_bytes_method); + else + assert (implementation->static_size == size); +#endif lcheader = (struct lcrecord_header *) allocate_lisp_storage (size); - set_lheader_implementation(&(lcheader->lheader), implementation); + set_lheader_implementation (&(lcheader->lheader), implementation); lcheader->next = all_lcrecords; #if 1 /* mly prefers to see small ID numbers */ lcheader->uid = lrecord_uid_counter++; @@ -574,7 +559,7 @@ } } if (lrecord->implementation->finalizer) - ((lrecord->implementation->finalizer) (lrecord, 0)); + lrecord->implementation->finalizer (lrecord, 0); xfree (lrecord); return; } @@ -636,9 +621,9 @@ } -/**********************************************************************/ -/* Debugger support */ -/**********************************************************************/ +/************************************************************************/ +/* Debugger support */ +/************************************************************************/ /* Give gdb/dbx enough information to decode Lisp Objects. We make sure certain symbols are defined, so gdb doesn't complain about expressions in src/gdbinit. Values are randomly chosen. @@ -657,11 +642,19 @@ dbg_USE_MINIMAL_TAGBITS = 0, dbg_Lisp_Type_Int = Lisp_Type_Int, #endif /* ! USE_MIMIMAL_TAGBITS */ + +#ifdef USE_UNION_TYPE + dbg_USE_UNION_TYPE = 1, +#else + dbg_USE_UNION_TYPE = 0, +#endif + #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1, #else dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0, #endif + dbg_Lisp_Type_Char = Lisp_Type_Char, dbg_Lisp_Type_Record = Lisp_Type_Record, #ifdef LRECORD_CONS @@ -709,10 +702,19 @@ other compilers) might optimize away the entire type declaration :-( */ } dbg_dummy; +/* A few macros turned into functions for ease of debugging. + Debuggers don't know about macros! */ +int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); +int +dbg_eq (Lisp_Object obj1, Lisp_Object obj2) +{ + return EQ (obj1, obj2); +} + -/**********************************************************************/ -/* Fixed-size type macros */ -/**********************************************************************/ +/************************************************************************/ +/* Fixed-size type macros */ +/************************************************************************/ /* For fixed-size types that are commonly used, we malloc() large blocks of memory at a time and subdivide them into chunks of the correct @@ -894,45 +896,46 @@ / sizeof (structtype)) #endif /* ALLOC_NO_POOLS */ -#define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ - \ -struct type##_block \ -{ \ - struct type##_block *prev; \ - structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ -}; \ - \ -static struct type##_block *current_##type##_block; \ -static int current_##type##_block_index; \ - \ -static structtype *type##_free_list; \ -static structtype *type##_free_list_tail; \ - \ -static void \ -init_##type##_alloc (void) \ -{ \ - current_##type##_block = 0; \ - current_##type##_block_index = countof (current_##type##_block->block); \ - type##_free_list = 0; \ - type##_free_list_tail = 0; \ -} \ - \ -static int gc_count_num_##type##_in_use, gc_count_num_##type##_freelist - -#define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) \ - do { \ - if (current_##type##_block_index \ - == countof (current_##type##_block->block)) \ +#define DECLARE_FIXED_TYPE_ALLOC(type, structtype) \ + \ +struct type##_block \ +{ \ + struct type##_block *prev; \ + structtype block[TYPE_ALLOC_SIZE (type, structtype)]; \ +}; \ + \ +static struct type##_block *current_##type##_block; \ +static int current_##type##_block_index; \ + \ +static structtype *type##_free_list; \ +static structtype *type##_free_list_tail; \ + \ +static void \ +init_##type##_alloc (void) \ +{ \ + current_##type##_block = 0; \ + current_##type##_block_index = \ + countof (current_##type##_block->block); \ + type##_free_list = 0; \ + type##_free_list_tail = 0; \ +} \ + \ +static int gc_count_num_##type##_in_use; \ +static int gc_count_num_##type##_freelist + +#define ALLOCATE_FIXED_TYPE_FROM_BLOCK(type, result) do { \ + if (current_##type##_block_index \ + == countof (current_##type##_block->block)) \ { \ - struct type##_block *__new__ = (struct type##_block *) \ - allocate_lisp_storage (sizeof (struct type##_block)); \ - __new__->prev = current_##type##_block; \ - current_##type##_block = __new__; \ + struct type##_block *AFTFB_new = (struct type##_block *) \ + allocate_lisp_storage (sizeof (struct type##_block)); \ + AFTFB_new->prev = current_##type##_block; \ + current_##type##_block = AFTFB_new; \ current_##type##_block_index = 0; \ } \ - (result) = \ - &(current_##type##_block->block[current_##type##_block_index++]); \ - } while (0) + (result) = \ + &(current_##type##_block->block[current_##type##_block_index++]); \ +} while (0) /* Allocate an instance of a type that is stored in blocks. TYPE is the "name" of the type, STRUCTTYPE is the corresponding @@ -1048,22 +1051,22 @@ #else /* !ERROR_CHECK_GC */ #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \ -do { * (structtype **) ((char *) ptr + sizeof (void *)) = \ +do { * (structtype **) ((char *) (ptr) + sizeof (void *)) = \ type##_free_list; \ - type##_free_list = ptr; \ + type##_free_list = (ptr); \ } while (0) #endif /* !ERROR_CHECK_GC */ /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */ -#define FREE_FIXED_TYPE(type, structtype, ptr) \ -do { structtype *_weird_ = (ptr); \ - ADDITIONAL_FREE_##type (_weird_); \ - deadbeef_memory (ptr, sizeof (structtype)); \ - PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, ptr); \ - MARK_STRUCT_AS_FREE (_weird_); \ - } while (0) +#define FREE_FIXED_TYPE(type, structtype, ptr) do { \ + structtype *FFT_ptr = (ptr); \ + ADDITIONAL_FREE_##type (FFT_ptr); \ + deadbeef_memory (FFT_ptr, sizeof (structtype)); \ + PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \ + MARK_STRUCT_AS_FREE (FFT_ptr); \ +} while (0) /* Like FREE_FIXED_TYPE() but used when we are explicitly freeing a structure through free_cons(), free_marker(), etc. @@ -1083,9 +1086,9 @@ -/**********************************************************************/ -/* Cons allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Cons allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); /* conses are used and freed so often that we set this really high */ @@ -1096,10 +1099,10 @@ static Lisp_Object mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - if (NILP (XCDR (obj))) + if (GC_NILP (XCDR (obj))) return XCAR (obj); - (markobj) (XCAR (obj)); + markobj (XCAR (obj)); return XCDR (obj); } @@ -1175,7 +1178,7 @@ Lisp_Object val = Qnil; Lisp_Object *argp = args + nargs; - while (nargs-- > 0) + while (argp > args) val = Fcons (*--argp, val); return val; } @@ -1255,9 +1258,9 @@ } -/**********************************************************************/ -/* Float allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Float allocation */ +/************************************************************************/ #ifdef LISP_FLOAT_TYPE @@ -1280,42 +1283,40 @@ #endif /* LISP_FLOAT_TYPE */ -/**********************************************************************/ -/* Vector allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Vector allocation */ +/************************************************************************/ #ifdef LRECORD_VECTOR static Lisp_Object mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct Lisp_Vector *ptr = XVECTOR (obj); + Lisp_Vector *ptr = XVECTOR (obj); int len = vector_length (ptr); int i; for (i = 0; i < len - 1; i++) - (markobj) (ptr->contents[i]); + markobj (ptr->contents[i]); return (len > 0) ? ptr->contents[len - 1] : Qnil; } static size_t size_vector (CONST void *lheader) { - /* * -1 because struct Lisp_Vector includes 1 slot */ - return sizeof (struct Lisp_Vector) + - ((((struct Lisp_Vector *) lheader)->size - 1) * sizeof (Lisp_Object)); + return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]); } static int -vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) +vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { int indice; - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) + int len = XVECTOR_LENGTH (obj1); + if (len != XVECTOR_LENGTH (obj2)) return 0; for (indice = 0; indice < len; indice++) { - if (!internal_equal (XVECTOR_DATA (o1) [indice], - XVECTOR_DATA (o2) [indice], + if (!internal_equal (XVECTOR_DATA (obj1) [indice], + XVECTOR_DATA (obj2) [indice], depth + 1)) return 0; } @@ -1331,17 +1332,15 @@ * knows how to handle vectors. */ 0, - size_vector, struct Lisp_Vector); + size_vector, Lisp_Vector); /* #### should allocate `small' vectors from a frob-block */ -static struct Lisp_Vector * +static Lisp_Vector * make_vector_internal (size_t sizei) { - size_t sizem = (sizeof (struct Lisp_Vector) - /* -1 because struct Lisp_Vector includes 1 slot */ - + (sizei - 1) * sizeof (Lisp_Object)); - struct Lisp_Vector *p = - (struct Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector); + /* no vector_next */ + size_t sizem = offsetof (Lisp_Vector, contents[sizei]); + Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector); p->size = sizei; return p; @@ -1352,14 +1351,12 @@ static Lisp_Object all_vectors; /* #### should allocate `small' vectors from a frob-block */ -static struct Lisp_Vector * +static Lisp_Vector * make_vector_internal (size_t sizei) { - size_t sizem = (sizeof (struct Lisp_Vector) - /* -1 because struct Lisp_Vector includes 1 slot, - * +1 to account for vector_next */ - + (sizei - 1 + 1) * sizeof (Lisp_Object)); - struct Lisp_Vector *p = (struct Lisp_Vector *) allocate_lisp_storage (sizem); + /* + 1 to account for vector_next */ + size_t sizem = offsetof (Lisp_Vector, contents[sizei+1]); + Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem); INCREMENT_CONS_COUNTER (sizem, "vector"); @@ -1376,7 +1373,7 @@ { int elt; Lisp_Object vector; - struct Lisp_Vector *p; + Lisp_Vector *p; if (length < 0) length = XINT (wrong_type_argument (Qnatnump, make_int (length))); @@ -1422,7 +1419,7 @@ { Lisp_Object vector; int elt; - struct Lisp_Vector *p = make_vector_internal (nargs); + Lisp_Vector *p = make_vector_internal (nargs); for (elt = 0; elt < nargs; elt++) vector_data(p)[elt] = args[elt]; @@ -1531,9 +1528,9 @@ } #endif /* unused */ -/**********************************************************************/ -/* Bit Vector allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Bit Vector allocation */ +/************************************************************************/ static Lisp_Object all_bit_vectors; @@ -1541,17 +1538,15 @@ static struct Lisp_Bit_Vector * make_bit_vector_internal (size_t sizei) { - size_t sizem = sizeof (struct Lisp_Bit_Vector) + - /* -1 because struct Lisp_Bit_Vector includes 1 slot */ - sizeof (long) * (BIT_VECTOR_LONG_STORAGE (sizei) - 1); - struct Lisp_Bit_Vector *p = - (struct Lisp_Bit_Vector *) allocate_lisp_storage (sizem); + size_t sizem = + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (sizei)]); + Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem); set_lheader_implementation (&(p->lheader), lrecord_bit_vector); INCREMENT_CONS_COUNTER (sizem, "bit-vector"); bit_vector_length (p) = sizei; - bit_vector_next (p) = all_bit_vectors; + bit_vector_next (p) = all_bit_vectors; /* make sure the extra bits in the last long are 0; the calling functions might not set them. */ p->bits[BIT_VECTOR_LONG_STORAGE (sizei) - 1] = 0; @@ -1640,76 +1635,78 @@ } -/**********************************************************************/ -/* Compiled-function allocation */ -/**********************************************************************/ - -DECLARE_FIXED_TYPE_ALLOC (compiled_function, struct Lisp_Compiled_Function); +/************************************************************************/ +/* Compiled-function allocation */ +/************************************************************************/ + +DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000 static Lisp_Object make_compiled_function (int make_pure) { - struct Lisp_Compiled_Function *b; - Lisp_Object new; - size_t size = sizeof (struct Lisp_Compiled_Function); + Lisp_Compiled_Function *f; + Lisp_Object fun; + size_t size = sizeof (Lisp_Compiled_Function); if (make_pure && check_purespace (size)) { - b = (struct Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used); - set_lheader_implementation (&(b->lheader), lrecord_compiled_function); + f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used); + set_lheader_implementation (&(f->lheader), lrecord_compiled_function); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION - b->lheader.pure = 1; + f->lheader.pure = 1; #endif pure_bytes_used += size; - bump_purestat (&purestat_bytecode, size); + bump_purestat (&purestat_function, size); } else { - ALLOCATE_FIXED_TYPE (compiled_function, struct Lisp_Compiled_Function, - b); - set_lheader_implementation (&(b->lheader), lrecord_compiled_function); + ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f); + set_lheader_implementation (&(f->lheader), lrecord_compiled_function); } - b->maxdepth = 0; - b->flags.documentationp = 0; - b->flags.interactivep = 0; - b->flags.domainp = 0; /* I18N3 */ - b->bytecodes = Qzero; - b->constants = Qzero; - b->arglist = Qnil; - b->doc_and_interactive = Qnil; + f->stack_depth = 0; + f->specpdl_depth = 0; + f->flags.documentationp = 0; + f->flags.interactivep = 0; + f->flags.domainp = 0; /* I18N3 */ + f->instructions = Qzero; + f->constants = Qzero; + f->arglist = Qnil; + f->doc_and_interactive = Qnil; #ifdef COMPILED_FUNCTION_ANNOTATION_HACK - b->annotated = Qnil; + f->annotated = Qnil; #endif - XSETCOMPILED_FUNCTION (new, b); - return new; + XSETCOMPILED_FUNCTION (fun, f); + return fun; } DEFUN ("make-byte-code", Fmake_byte_code, 4, MANY, 0, /* Return a new compiled-function object. -Usage: (arglist instructions constants stack-size - &optional doc-string interactive-spec) +Usage: (arglist instructions constants stack-depth + &optional doc-string interactive) Note that, unlike all other emacs-lisp functions, calling this with five arguments is NOT the same as calling it with six arguments, the last of which is nil. If the INTERACTIVE arg is specified as nil, then that means that this function was defined with `(interactive)'. If the arg is not specified, then that means the function is not interactive. This is terrible behavior which is retained for compatibility with old -`.elc' files which expected these semantics. +`.elc' files which expect these semantics. */ (int nargs, Lisp_Object *args)) { -/* In a non-insane world this function would have this arglist... - (arglist, instructions, constants, stack_size, doc_string, interactive) - Lisp_Object arglist, instructions, constants, stack_size, doc_string, - interactive; +/* In a non-insane world this function would have this arglist... + (arglist instructions constants stack_depth &optional doc_string interactive) */ + Lisp_Object fun = make_compiled_function (purify_flag); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + Lisp_Object arglist = args[0]; Lisp_Object instructions = args[1]; Lisp_Object constants = args[2]; - Lisp_Object stack_size = args[3]; + Lisp_Object stack_depth = args[3]; Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil; Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound; + /* Don't purecopy the doc references in instructions because it's wasteful; they will get fixed up later. @@ -1720,143 +1717,140 @@ 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; - - if (nargs > 6) + Lisp_Object (*cons) (Lisp_Object, Lisp_Object) + = purify_flag ? pure_cons : Fcons; + + 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); + } + f->instructions = instructions; + + if (!NILP (constants)) + CHECK_VECTOR (constants); + f->constants = constants; + + 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)) + { + 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; } - CHECK_NATNUM (stack_size); - /* doc_string may be nil, string, int, or a cons (string . int). */ - - /* interactive may be list or string (or unbound). */ +#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ + + /* 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) + { + interactive = Fpurecopy (interactive); + if (STRINGP (interactive)) + bump_purestat (&purestat_string_interactive, + pure_sizeof (interactive)); + } + 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 (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); + + if (!purified (f->arglist)) + f->arglist = Fpurecopy (f->arglist); /* Statistics are kept differently for the constants */ - if (!purified (constants)) -#ifdef PURESTAT + if (!purified (f->constants)) { - int old = purecopying_for_bytecode; - purecopying_for_bytecode = 1; - constants = Fpurecopy (constants); - purecopying_for_bytecode = old; - } -#else - constants = Fpurecopy (constants); -#endif /* PURESTAT */ - #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 */ + } + + optimize_compiled_function (fun); + + bump_purestat (&purestat_opaque_instructions, + pure_sizeof (f->instructions)); } - { - 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 */ - -#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; - - return val; - } + return fun; } -/**********************************************************************/ -/* Symbol allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Symbol allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (symbol, struct Lisp_Symbol); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_symbol 1000 @@ -1865,31 +1859,31 @@ Return a newly allocated uninterned symbol whose name is NAME. Its value and function definition are void, and its property list is nil. */ - (str)) + (name)) { Lisp_Object val; struct Lisp_Symbol *p; - CHECK_STRING (str); + CHECK_STRING (name); ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p); #ifdef LRECORD_SYMBOL set_lheader_implementation (&(p->lheader), lrecord_symbol); #endif - p->name = XSTRING (str); - p->plist = Qnil; - p->value = Qunbound; + p->name = XSTRING (name); + p->plist = Qnil; + p->value = Qunbound; p->function = Qunbound; - p->obarray = Qnil; + p->obarray = Qnil; symbol_next (p) = 0; XSETSYMBOL (val, p); return val; } -/**********************************************************************/ -/* Extent allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Extent allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (extent, struct extent); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_extent 1000 @@ -1900,7 +1894,6 @@ struct extent *e; ALLOCATE_FIXED_TYPE (extent, struct extent, e); - /* xzero (*e); */ set_lheader_implementation (&(e->lheader), lrecord_extent); extent_object (e) = Qnil; set_extent_start (e, -1); @@ -1917,9 +1910,9 @@ } -/**********************************************************************/ -/* Event allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Event allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (event, struct Lisp_Event); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_event 1000 @@ -1938,9 +1931,9 @@ } -/**********************************************************************/ -/* Marker allocation */ -/**********************************************************************/ +/************************************************************************/ +/* Marker allocation */ +/************************************************************************/ DECLARE_FIXED_TYPE_ALLOC (marker, struct Lisp_Marker); #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_marker 1000 @@ -1982,9 +1975,9 @@ } -/**********************************************************************/ -/* String allocation */ -/**********************************************************************/ +/************************************************************************/ +/* String allocation */ +/************************************************************************/ /* The data for "short" strings generally resides inside of structs of type string_chars_block. The Lisp_String structure is allocated just like any @@ -2016,11 +2009,11 @@ } static int -string_equal (Lisp_Object o1, Lisp_Object o2, int depth) +string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { Bytecount len; - return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) && - !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)); + return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && + !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); } DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, @@ -2335,30 +2328,35 @@ */ (length, 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)); - - val = make_uninit_string (len * XINT (length)); + Bufbyte init_str[MAX_EMCHAR_LEN]; + int len = set_charptr_emchar (init_str, XCHAR (init)); + Lisp_Object val = make_uninit_string (len * XINT (length)); + if (len == 1) /* Optimize the single-byte case */ memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val)); else { - int i, j, k; + int i; Bufbyte *ptr = XSTRING_DATA (val); - k = 0; - for (i = 0; i < XINT (length); i++) - for (j = 0; j < len; j++) - ptr[k++] = str[j]; + for (i = XINT (length); i; i--) + { + Bufbyte *init_ptr = init_str; + switch (len) + { + case 4: *ptr++ = *init_ptr++; + case 3: *ptr++ = *init_ptr++; + case 2: *ptr++ = *init_ptr++; + case 1: *ptr++ = *init_ptr++; + } + } } + return val; } - return val; } DEFUN ("string", Fstring, 0, MANY, 0, /* @@ -2572,23 +2570,22 @@ /* Make sure the size is correct. This will catch, for example, putting a window configuration on the wrong free list. */ if (implementation->size_in_bytes_method) - assert (((implementation->size_in_bytes_method) (lheader)) - == list->size); + assert (implementation->size_in_bytes_method (lheader) == list->size); else assert (implementation->static_size == list->size); #endif /* ERROR_CHECK_GC */ if (implementation->finalizer) - ((implementation->finalizer) (lheader, 0)); + implementation->finalizer (lheader, 0); free_header->chain = list->free; free_header->lcheader.free = 1; list->free = lcrecord; } -/**********************************************************************/ -/* Purity of essence, peace on earth */ -/**********************************************************************/ +/************************************************************************/ +/* Purity of essence, peace on earth */ +/************************************************************************/ static int symbols_initialized; @@ -2641,7 +2638,7 @@ #ifdef PURESTAT bump_purestat (&purestat_string_all, size); - if (purecopying_for_bytecode) + if (purecopying_function_constants) bump_purestat (&purestat_string_other_function, size); #endif /* PURESTAT */ @@ -2760,16 +2757,15 @@ make_pure_vector (size_t len, Lisp_Object init) { Lisp_Object new; - struct Lisp_Vector *v; - size_t size = (sizeof (struct Lisp_Vector) - + (len - 1) * sizeof (Lisp_Object)); + Lisp_Vector *v; + size_t size = offsetof (Lisp_Vector, contents[len]); init = Fpurecopy (init); if (!check_purespace (size)) return make_vector (len, init); - v = (struct Lisp_Vector *) (PUREBEG + pure_bytes_used); + v = (Lisp_Vector *) (PUREBEG + pure_bytes_used); #ifdef LRECORD_VECTOR set_lheader_implementation (&(v->header.lheader), lrecord_vector); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION @@ -2813,115 +2809,107 @@ */ (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)) + { + 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)) { -#ifndef LRECORD_CONS - case Lisp_Type_Cons: + /* 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 */ - -#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 */ - - 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 */ + 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 (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); - } + 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; } - return 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; + + memcpy (new_opaque, old_opaque, size); +#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION + lheader->pure = 1; +#endif + new_opaque->header.next = 0; + + XSETOPAQUE (pure_obj, new_opaque); + return pure_obj; + } + else + { + signal_simple_error ("Can't purecopy %S", obj); + } + return obj; /* Unreached */ } @@ -2999,15 +2987,14 @@ purestat_vector_other.nbytes = purestat_vector_all.nbytes - - purestat_vector_bytecode_constants.nbytes; + purestat_vector_constants.nbytes; purestat_vector_other.nobjects = purestat_vector_all.nobjects - - purestat_vector_bytecode_constants.nobjects; + purestat_vector_constants.nobjects; purestat_string_other.nbytes = purestat_string_all.nbytes - (purestat_string_pname.nbytes + - purestat_string_bytecodes.nbytes + purestat_string_interactive.nbytes + purestat_string_documentation.nbytes + #ifdef I18N3 @@ -3018,7 +3005,6 @@ purestat_string_other.nobjects = purestat_string_all.nobjects - (purestat_string_pname.nobjects + - purestat_string_bytecodes.nobjects + purestat_string_interactive.nobjects + purestat_string_documentation.nobjects + #ifdef I18N3 @@ -3026,59 +3012,53 @@ #endif purestat_string_other_function.nobjects); - message (" %-26s Total Bytes", ""); - - { - int j; - - 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)); - } - } + message (" %-34s Objects Bytes", ""); + + 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); + #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))) + Lisp_Object symbol = XCAR (plist); + int size = XINT (XCAR (XCDR (plist))); + if (size > 0) { - 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?! */ - { - Fprin1 (tem, Qexternal_debugging_output); - tem = Qnil; + char buf [100]; + char *s = buf; + memcpy (buf, + string_data (XSYMBOL (symbol)->name), + string_length (XSYMBOL (symbol)->name) + 1); + while (*s++) if (*s == '-') *s = ' '; + *(s-1) = ':'; *s = 0; + message (" %-34s %6d", buf, size); } } UNGCPRO; - garbage_collect_1 (); /* GC garbage_collect's garbage */ + garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */ } clear_message (); @@ -3091,9 +3071,15 @@ } -/**********************************************************************/ -/* staticpro */ -/**********************************************************************/ +/************************************************************************/ +/* Garbage Collection */ +/************************************************************************/ + +/* This will be used more extensively In The Future */ +static int last_lrecord_type_index_assigned; + +CONST struct lrecord_implementation *lrecord_implementations_table[128]; +#define max_lrecord_type (countof (lrecord_implementations_table) - 1) struct gcpro *gcprolist; @@ -3131,23 +3117,27 @@ { tail_recurse: - if (EQ (obj, Qnull_pointer)) - return; - if (!POINTER_TYPE_P (XGCTYPE (obj))) - return; - if (PURIFIED (XPNTR (obj))) - return; +#ifdef ERROR_CHECK_GC + assert (! (GC_EQ (obj, Qnull_pointer))); +#endif + /* Checks we used to perform */ + /* if (EQ (obj, Qnull_pointer)) return; */ + /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */ + /* if (PURIFIED (XPNTR (obj))) return; */ + switch (XGCTYPE (obj)) { #ifndef LRECORD_CONS case Lisp_Type_Cons: { struct Lisp_Cons *ptr = XCONS (obj); + if (PURIFIED (ptr)) + break; if (CONS_MARKED_P (ptr)) break; MARK_CONS (ptr); /* If the cdr is nil, tail-recurse on the car. */ - if (NILP (ptr->cdr)) + if (GC_NILP (ptr->cdr)) { obj = ptr->car; } @@ -3161,24 +3151,28 @@ #endif case Lisp_Type_Record: - /* case Lisp_Symbol_Value_Magic: */ { struct lrecord_header *lheader = XRECORD_LHEADER (obj); - CONST struct lrecord_implementation *implementation - = LHEADER_IMPLEMENTATION (lheader); +#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION) + assert (lheader->type <= last_lrecord_type_index_assigned); +#endif + if (PURIFIED (lheader)) + return; if (! MARKED_RECORD_HEADER_P (lheader) && ! UNMARKABLE_RECORD_HEADER_P (lheader)) { + CONST struct lrecord_implementation *implementation = + LHEADER_IMPLEMENTATION (lheader); MARK_RECORD_HEADER (lheader); #ifdef ERROR_CHECK_GC if (!implementation->basic_p) assert (! ((struct lcrecord_header *) lheader)->free); #endif - if (implementation->marker != 0) + if (implementation->marker) { - obj = ((implementation->marker) (obj, mark_object)); - if (!NILP (obj)) goto tail_recurse; + obj = implementation->marker (obj, mark_object); + if (!GC_NILP (obj)) goto tail_recurse; } } } @@ -3188,6 +3182,8 @@ case Lisp_Type_String: { struct Lisp_String *ptr = XSTRING (obj); + if (PURIFIED (ptr)) + return; if (!XMARKBIT (ptr->plist)) { @@ -3206,8 +3202,12 @@ case Lisp_Type_Vector: { struct Lisp_Vector *ptr = XVECTOR (obj); - int len = vector_length (ptr); - int i; + int len, i; + + if (PURIFIED (ptr)) + return; + + len = vector_length (ptr); if (len < 0) break; /* Already marked */ @@ -3228,6 +3228,9 @@ { struct Lisp_Symbol *sym = XSYMBOL (obj); + if (PURIFIED (sym)) + return; + while (!XMARKBIT (sym->plist)) { XMARK (sym->plist); @@ -3239,8 +3242,8 @@ * Lisp_Object. Fix it up and pass to mark_object. */ Lisp_Object symname; - XSETSTRING(symname, sym->name); - mark_object(symname); + XSETSTRING (symname, sym->name); + mark_object (symname); } if (!symbol_next (sym)) { @@ -3255,8 +3258,15 @@ break; #endif /* !LRECORD_SYMBOL */ + /* Check for invalid Lisp_Object types */ +#if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS) + case Lisp_Type_Int: + case Lisp_Type_Char: + break; default: - abort (); + abort(); + break; +#endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */ } } @@ -3286,15 +3296,6 @@ /* Simpler than mark-object, because pure structure can't have any circularities */ -#if 0 /* unused */ -static int idiot_c_doesnt_have_closures; -static void -idiot_c (Lisp_Object obj) -{ - idiot_c_doesnt_have_closures += pure_sizeof (obj, 1); -} -#endif /* unused */ - static size_t pure_string_sizeof (Lisp_Object obj) { @@ -3314,120 +3315,40 @@ } } -/* 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)) { - -#ifndef LRECORD_STRING - case Lisp_Type_String: - total += pure_string_sizeof (obj); - break; -#endif /* ! LRECORD_STRING */ - + struct lrecord_header *lheader = XRECORD_LHEADER (obj); + CONST struct lrecord_implementation *implementation + = LHEADER_IMPLEMENTATION (lheader); + + return implementation->size_in_bytes_method + ? implementation->size_in_bytes_method (lheader) + : implementation->static_size; + } #ifndef LRECORD_VECTOR - case Lisp_Type_Vector: - { - struct Lisp_Vector *ptr = XVECTOR (obj); - int len = vector_length (ptr); - - total += (sizeof (struct Lisp_Vector) - + (len - 1) * sizeof (Lisp_Object)); -#if 0 /* unused */ - if (!recurse) - break; - { - int i; - for (i = 0; i < len - 1; i++) - total += pure_sizeof (ptr->contents[i], 1); - } - if (len > 0) - { - obj = ptr->contents[len - 1]; - goto tail_recurse; - } -#endif /* unused */ - } - break; + else if (VECTORP (obj)) + return offsetof (Lisp_Vector, contents[XVECTOR_LENGTH (obj)]); #endif /* !LRECORD_VECTOR */ - case Lisp_Type_Record: - { - struct lrecord_header *lheader = XRECORD_LHEADER (obj); - CONST struct lrecord_implementation *implementation - = LHEADER_IMPLEMENTATION (lheader); - -#ifdef LRECORD_STRING - if (STRINGP (obj)) - total += pure_string_sizeof (obj); - else -#endif - if (implementation->size_in_bytes_method) - total += ((implementation->size_in_bytes_method) (lheader)); - else - total += implementation->static_size; - -#if 0 /* unused */ - if (!recurse) - break; - - if (implementation->marker != 0) - { - int old = idiot_c_doesnt_have_closures; - - idiot_c_doesnt_have_closures = 0; - obj = ((implementation->marker) (obj, idiot_c)); - total += idiot_c_doesnt_have_closures; - idiot_c_doesnt_have_closures = old; - - if (!NILP (obj)) goto tail_recurse; - } -#endif /* unused */ - } - break; - #ifndef LRECORD_CONS - case Lisp_Type_Cons: - { - struct Lisp_Cons *ptr = XCONS (obj); - total += sizeof (*ptr); -#if 0 /* unused */ - if (!recurse) - break; - /* If the cdr is nil, tail-recurse on the car. */ - if (NILP (ptr->cdr)) - { - obj = ptr->car; - } - else - { - total += pure_sizeof (ptr->car, 1); - obj = ptr->cdr; - } - goto tail_recurse; -#endif /* unused */ - } - break; -#endif - - /* Others can't be purified */ - default: - abort (); - } - return total; + else if (CONSP (obj)) + return sizeof (struct Lisp_Cons); +#endif /* !LRECORD_CONS */ + else + /* Others can't be purified */ + abort (); + return 0; /* unreached */ } #endif /* PURESTAT */ @@ -3449,12 +3370,6 @@ /* static int gc_count_total_records_used, gc_count_records_total_size; */ -/* This will be used more extensively In The Future */ -static int last_lrecord_type_index_assigned; - -CONST struct lrecord_implementation *lrecord_implementations_table[128]; -#define max_lrecord_type (countof (lrecord_implementations_table) - 1) - int lrecord_type_index (CONST struct lrecord_implementation *implementation) { @@ -3515,7 +3430,7 @@ else { size_t sz = (implementation->size_in_bytes_method - ? ((implementation->size_in_bytes_method) (h)) + ? implementation->size_in_bytes_method (h) : implementation->static_size); if (free_p) @@ -3557,7 +3472,7 @@ if (!MARKED_RECORD_HEADER_P (h) && ! (header->free)) { if (LHEADER_IMPLEMENTATION (h)->finalizer) - ((LHEADER_IMPLEMENTATION (h)->finalizer) (h, 0)); + LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); } } @@ -3568,7 +3483,7 @@ { UNMARK_RECORD_HEADER (h); num_used++; - /* total_size += ((n->implementation->size_in_bytes) (h));*/ + /* total_size += n->implementation->size_in_bytes (h);*/ prev = &(header->next); header = *prev; tick_lcrecord_stats (h, 0); @@ -3600,16 +3515,15 @@ for (vector = *prev; VECTORP (vector); ) { - struct Lisp_Vector *v = XVECTOR (vector); + Lisp_Vector *v = XVECTOR (vector); int len = v->size; if (len < 0) /* marked */ { len = - (len + 1); v->size = len; total_size += len; - total_storage += (MALLOC_OVERHEAD - + sizeof (struct Lisp_Vector) - + (len - 1 + 1) * sizeof (Lisp_Object)); + total_storage += + MALLOC_OVERHEAD + offsetof (Lisp_Vector, contents[len + 1]); num_used++; prev = &(vector_next (v)); vector = *prev; @@ -3642,16 +3556,15 @@ their implementation */ for (bit_vector = *prev; !EQ (bit_vector, Qzero); ) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); + Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); int len = v->size; if (MARKED_RECORD_P (bit_vector)) { UNMARK_RECORD_HEADER (&(v->lheader)); total_size += len; - total_storage += (MALLOC_OVERHEAD - + sizeof (struct Lisp_Bit_Vector) - + (BIT_VECTOR_LONG_STORAGE (len) - 1) - * sizeof (long)); + total_storage += + MALLOC_OVERHEAD + + offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]); num_used++; prev = &(bit_vector_next (v)); bit_vector = *prev; @@ -3676,41 +3589,41 @@ #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ do { \ - struct typename##_block *_frob_current; \ - struct typename##_block **_frob_prev; \ - int _frob_limit; \ + struct typename##_block *SFTB_current; \ + struct typename##_block **SFTB_prev; \ + int SFTB_limit; \ int num_free = 0, num_used = 0; \ \ - for (_frob_prev = ¤t_##typename##_block, \ - _frob_current = current_##typename##_block, \ - _frob_limit = current_##typename##_block_index; \ - _frob_current; \ + for (SFTB_prev = ¤t_##typename##_block, \ + SFTB_current = current_##typename##_block, \ + SFTB_limit = current_##typename##_block_index; \ + SFTB_current; \ ) \ { \ - int _frob_iii; \ + int SFTB_iii; \ \ - for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \ + for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ { \ - obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \ + obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ \ - if (FREE_STRUCT_P (_frob_victim)) \ + if (FREE_STRUCT_P (SFTB_victim)) \ { \ num_free++; \ } \ - else if (!MARKED_##typename##_P (_frob_victim)) \ + else if (!MARKED_##typename##_P (SFTB_victim)) \ { \ num_free++; \ - FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \ + FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ } \ else \ { \ num_used++; \ - UNMARK_##typename (_frob_victim); \ + UNMARK_##typename (SFTB_victim); \ } \ } \ - _frob_prev = &(_frob_current->prev); \ - _frob_current = _frob_current->prev; \ - _frob_limit = countof (current_##typename##_block->block); \ + SFTB_prev = &(SFTB_current->prev); \ + SFTB_current = SFTB_current->prev; \ + SFTB_limit = countof (current_##typename##_block->block); \ } \ \ gc_count_num_##typename##_in_use = num_used; \ @@ -3719,77 +3632,77 @@ #else /* !ERROR_CHECK_GC */ -#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ -do { \ - struct typename##_block *_frob_current; \ - struct typename##_block **_frob_prev; \ - int _frob_limit; \ - int num_free = 0, num_used = 0; \ - \ - typename##_free_list = 0; \ - \ - for (_frob_prev = ¤t_##typename##_block, \ - _frob_current = current_##typename##_block, \ - _frob_limit = current_##typename##_block_index; \ - _frob_current; \ - ) \ - { \ - int _frob_iii; \ - int _frob_empty = 1; \ - obj_type *_frob_old_free_list = typename##_free_list; \ - \ - for (_frob_iii = 0; _frob_iii < _frob_limit; _frob_iii++) \ - { \ - obj_type *_frob_victim = &(_frob_current->block[_frob_iii]); \ - \ - if (FREE_STRUCT_P (_frob_victim)) \ - { \ - num_free++; \ - PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, _frob_victim); \ - } \ - else if (!MARKED_##typename##_P (_frob_victim)) \ - { \ - num_free++; \ - FREE_FIXED_TYPE (typename, obj_type, _frob_victim); \ - } \ - else \ - { \ - _frob_empty = 0; \ - num_used++; \ - UNMARK_##typename (_frob_victim); \ - } \ - } \ - if (!_frob_empty) \ - { \ - _frob_prev = &(_frob_current->prev); \ - _frob_current = _frob_current->prev; \ - } \ - else if (_frob_current == current_##typename##_block \ - && !_frob_current->prev) \ - { \ - /* No real point in freeing sole allocation block */ \ - break; \ - } \ - else \ - { \ - struct typename##_block *_frob_victim_block = _frob_current; \ - if (_frob_victim_block == current_##typename##_block) \ - current_##typename##_block_index \ - = countof (current_##typename##_block->block); \ - _frob_current = _frob_current->prev; \ - { \ - *_frob_prev = _frob_current; \ - xfree (_frob_victim_block); \ - /* Restore free list to what it was before victim was swept */ \ - typename##_free_list = _frob_old_free_list; \ - num_free -= _frob_limit; \ - } \ - } \ - _frob_limit = countof (current_##typename##_block->block); \ - } \ - \ - gc_count_num_##typename##_in_use = num_used; \ - gc_count_num_##typename##_freelist = num_free; \ +#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \ +do { \ + struct typename##_block *SFTB_current; \ + struct typename##_block **SFTB_prev; \ + int SFTB_limit; \ + int num_free = 0, num_used = 0; \ + \ + typename##_free_list = 0; \ + \ + for (SFTB_prev = ¤t_##typename##_block, \ + SFTB_current = current_##typename##_block, \ + SFTB_limit = current_##typename##_block_index; \ + SFTB_current; \ + ) \ + { \ + int SFTB_iii; \ + int SFTB_empty = 1; \ + obj_type *SFTB_old_free_list = typename##_free_list; \ + \ + for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \ + { \ + obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \ + \ + if (FREE_STRUCT_P (SFTB_victim)) \ + { \ + num_free++; \ + PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ + } \ + else if (!MARKED_##typename##_P (SFTB_victim)) \ + { \ + num_free++; \ + FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \ + } \ + else \ + { \ + SFTB_empty = 0; \ + num_used++; \ + UNMARK_##typename (SFTB_victim); \ + } \ + } \ + if (!SFTB_empty) \ + { \ + SFTB_prev = &(SFTB_current->prev); \ + SFTB_current = SFTB_current->prev; \ + } \ + else if (SFTB_current == current_##typename##_block \ + && !SFTB_current->prev) \ + { \ + /* No real point in freeing sole allocation block */ \ + break; \ + } \ + else \ + { \ + struct typename##_block *SFTB_victim_block = SFTB_current; \ + if (SFTB_victim_block == current_##typename##_block) \ + current_##typename##_block_index \ + = countof (current_##typename##_block->block); \ + SFTB_current = SFTB_current->prev; \ + { \ + *SFTB_prev = SFTB_current; \ + xfree (SFTB_victim_block); \ + /* Restore free list to what it was before victim was swept */ \ + typename##_free_list = SFTB_old_free_list; \ + num_free -= SFTB_limit; \ + } \ + } \ + SFTB_limit = countof (current_##typename##_block->block); \ + } \ + \ + gc_count_num_##typename##_in_use = num_used; \ + gc_count_num_##typename##_freelist = num_free; \ } while (0) #endif /* !ERROR_CHECK_GC */ @@ -3875,7 +3788,7 @@ #define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) #define ADDITIONAL_FREE_compiled_function(ptr) - SWEEP_FIXED_TYPE_BLOCK (compiled_function, struct Lisp_Compiled_Function); + SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function); } @@ -4193,33 +4106,65 @@ static int marked_p (Lisp_Object obj) { - if (EQ (obj, Qnull_pointer)) return 1; - if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; - if (PURIFIED (XPNTR (obj))) return 1; +#ifdef ERROR_CHECK_GC + assert (! (GC_EQ (obj, Qnull_pointer))); +#endif + /* Checks we used to perform. */ + /* if (EQ (obj, Qnull_pointer)) return 1; */ + /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */ + /* if (PURIFIED (XPNTR (obj))) return 1; */ + switch (XGCTYPE (obj)) { #ifndef LRECORD_CONS case Lisp_Type_Cons: - return XMARKBIT (XCAR (obj)); + { + struct Lisp_Cons *ptr = XCONS (obj); + return PURIFIED (ptr) || XMARKBIT (ptr->car); + } #endif case Lisp_Type_Record: - return MARKED_RECORD_HEADER_P (XRECORD_LHEADER (obj)); + { + struct lrecord_header *lheader = XRECORD_LHEADER (obj); +#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION) + assert (lheader->type <= last_lrecord_type_index_assigned); +#endif + return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader); + } #ifndef LRECORD_STRING case Lisp_Type_String: - return XMARKBIT (XSTRING (obj)->plist); + { + struct Lisp_String *ptr = XSTRING (obj); + return PURIFIED (ptr) || XMARKBIT (ptr->plist); + } #endif /* ! LRECORD_STRING */ #ifndef LRECORD_VECTOR case Lisp_Type_Vector: - return XVECTOR_LENGTH (obj) < 0; + { + struct Lisp_Vector *ptr = XVECTOR (obj); + return PURIFIED (ptr) || vector_length (ptr) < 0; + } #endif /* !LRECORD_VECTOR */ #ifndef LRECORD_SYMBOL case Lisp_Type_Symbol: - return XMARKBIT (XSYMBOL (obj)->plist); + { + struct Lisp_Symbol *ptr = XSYMBOL (obj); + return PURIFIED (ptr) || XMARKBIT (ptr->plist); + } #endif + + /* Ints and Chars don't need GC */ +#if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC) default: - abort (); + return 1; +#else + default: + abort(); + case Lisp_Type_Int: + case Lisp_Type_Char: + return 1; +#endif } - return 0; /* suppress compiler warning */ } static void @@ -4297,7 +4242,7 @@ { /* It's important that certain information from the environment not get dumped with the executable (pathnames, environment variables, etc.). - To make it easier to tell when this has happend with strings(1) we + To make it easier to tell when this has happened with strings(1) we clear some known-to-be-garbage blocks of memory, so that leftover results of old evaluation don't look like potential problems. But first we set some notable variables to nil and do one more GC, @@ -4370,8 +4315,10 @@ void garbage_collect_1 (void) { +#if MAX_SAVE_STACK > 0 char stack_top_variable; extern char *stack_bottom; +#endif int i; struct frame *f; int speccount; @@ -4385,13 +4332,24 @@ || preparing_for_armageddon) return; + /* We used to call selected_frame() here. + + The following functions cannot be called inside GC + so we move to after the above tests. */ + { + Lisp_Object frame; + Lisp_Object device = Fselected_device (Qnil); + if (NILP (device)) /* Could happen during startup, eg. if always_gc */ + return; + frame = DEVICE_SELECTED_FRAME (XDEVICE (device)); + if (NILP (frame)) + signal_simple_error ("No frames exist on device", device); + f = XFRAME (frame); + } + pre_gc_cursor = Qnil; cursor_changed = 0; - /* This function cannot be called inside GC so we move to after the */ - /* above tests */ - f = selected_frame (); - GCPRO1 (pre_gc_cursor); /* Very important to prevent GC during any of the following @@ -4486,10 +4444,6 @@ for (i = 0; i < staticidx; i++) { -#ifdef GDB_SUCKS - printf ("%d\n", i); - debug_print (*staticvec[i]); -#endif mark_object (*(staticvec[i])); } @@ -4528,29 +4482,21 @@ } /* OK, now do the after-mark stuff. This is for things that - are only marked when something else is marked (e.g. weak hashtables). + are only marked when something else is marked (e.g. weak hash tables). There may be complex dependencies between such objects -- e.g. - a weak hashtable might be unmarked, but after processing a later - weak hashtable, the former one might get marked. So we have to + a weak hash table might be unmarked, but after processing a later + weak hash table, the former one might get marked. So we have to iterate until nothing more gets marked. */ - { - int did_mark; - /* Need to iterate until there's nothing more to mark, in case - of chains of mark dependencies. */ - do - { - did_mark = 0; - did_mark += !!finish_marking_weak_hashtables (marked_p, mark_object); - did_mark += !!finish_marking_weak_lists (marked_p, mark_object); - } - while (did_mark); - } + + while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 || + finish_marking_weak_lists (marked_p, mark_object) > 0) + ; /* And prune (this needs to be called after everything else has been marked and before we do any sweeping). */ /* #### this is somewhat ad-hoc and should probably be an object method */ - prune_weak_hashtables (marked_p); + prune_weak_hash_tables (marked_p); prune_weak_lists (marked_p); prune_specifiers (marked_p); prune_syntax_tables (marked_p); @@ -4610,15 +4556,6 @@ return; } -#ifdef EMACS_BTL - /* This isn't actually called. BTL recognizes the stack frame of the top - of the garbage collector by noting that PC is between &garbage_collect_1 - and &BTL_after_garbage_collect_1_stub. So this fn must be right here. - There's not any other way to know the address of the end of a function. - */ -void BTL_after_garbage_collect_1_stub () { abort (); } -#endif /* EMACS_BTL */ - /* Debugging aids. */ static Lisp_Object @@ -4630,13 +4567,12 @@ return cons3 (intern (name), make_int (value), tail); } -#define HACK_O_MATIC(type, name, pl) \ - { \ - int s = 0; \ - struct type##_block *x = current_##type##_block; \ - while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ - (pl) = gc_plist_hack ((name), s, (pl)); \ - } +#define HACK_O_MATIC(type, name, pl) do { \ + int s = 0; \ + struct type##_block *x = current_##type##_block; \ + while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ + (pl) = gc_plist_hack ((name), s, (pl)); \ +} while (0) DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /* Reclaim storage for Lisp objects no longer needed. @@ -4948,16 +4884,6 @@ { int iii; -#ifdef PURESTAT - for (iii = 0; iii < countof (purestats); iii++) - { - if (! purestats[iii]) continue; - purestats[iii]->nobjects = 0; - purestats[iii]->nbytes = 0; - } - purecopying_for_bytecode = 0; -#endif /* PURESTAT */ - last_lrecord_type_index_assigned = -1; for (iii = 0; iii < countof (lrecord_implementations_table); iii++) { diff -r 76b7d63099ad -r 8626e4521993 src/alloca.s --- a/src/alloca.s Mon Aug 13 11:06:08 2007 +0200 +++ b/src/alloca.s Mon Aug 13 11:07:10 2007 +0200 @@ -64,7 +64,7 @@ data text globl _alloca -_alloca +_alloca move.l (sp)+,a0 ; pop return addr from top of stack move.l (sp)+,d0 ; pop size in bytes from top of stack add.l #ROUND,d0 ; round size up to long word @@ -117,7 +117,7 @@ alloca: #ifdef MOTOROLA_DELTA /* slightly modified version of alloca to motorola sysV/68 pcc - based - compiler. + compiler. this compiler saves used registers relative to %sp instead of %fp. alright, just make new copy of saved register set whenever we allocate new space from stack.. @@ -186,7 +186,7 @@ move.l sp,d1 ; get current SP value sub.l d0,d1 ; adjust to reflect required size... sub.l #MAXREG*4,d1 ; ...and space needed for registers - and.l #-4,d1 ; backup to longword boundry + and.l #-4,d1 ; backup to longword boundary move.l sp,a0 ; save old SP value for register copy move.l d1,sp ; set the new SP value tst.b -4096(sp) ; grab an extra page (to cover caller) @@ -256,9 +256,9 @@ * We have to copy registers, and therefore waste 32 bytes. * * Stack layout: - * new sp -> junk + * new sp -> junk * registers (copy) - * r0 -> new data + * r0 -> new data * | (orig retval) * | (orig arg) * old sp -> regs (orig) diff -r 76b7d63099ad -r 8626e4521993 src/backtrace.h --- a/src/backtrace.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/backtrace.h Mon Aug 13 11:07:10 2007 +0200 @@ -46,12 +46,6 @@ If nargs is UNEVALLED, args points to slot holding list of unevalled args */ int pdlcount; /* specpdl_depth () when invoked */ -#ifdef EMACS_BTL - /* The value of a Lisp integer that specifies the symbol being - "invoked" by this node in the backtrace, or 0 if the backtrace - doesn't correspond to a such an invocation */ - int id_number; -#endif char evalargs; /* Nonzero means call value of debugger when done with this operation. */ char debug_on_exit; @@ -116,7 +110,8 @@ struct specbinding { - Lisp_Object symbol, old_value; + Lisp_Object symbol; + Lisp_Object old_value; Lisp_Object (*func) (Lisp_Object); /* for unwind-protect */ }; @@ -132,7 +127,7 @@ and Fcondition_case thus knows which clause to run. */ Lisp_Object chosen_clause; - /* Used to effect the longjump out to the handler. */ + /* Used to effect the longjmp() out to the handler. */ struct catchtag *tag; /* The next enclosing handler. */ @@ -149,4 +144,179 @@ extern struct catchtag *catchlist; extern struct backtrace *backtrace_list; +/* Most callers should simply use specbind() and unbind_to(), but if + speed is REALLY IMPORTANT, you can use the faster macros below */ +void specbind_magic (Lisp_Object, Lisp_Object); +void grow_specpdl (size_t reserved); +void unbind_to_hairy (int); +extern int specpdl_size; + +/* Inline version of specbind(). + Use this instead of specbind() if speed is sufficiently important + to save the overhead of even a single function call. */ +#define SPECBIND(symbol_object, value_object) do { \ + Lisp_Object SB_symbol = (symbol_object); \ + Lisp_Object SB_newval = (value_object); \ + Lisp_Object SB_oldval; \ + struct Lisp_Symbol *SB_sym; \ + \ + SPECPDL_RESERVE (1); \ + \ + CHECK_SYMBOL (SB_symbol); \ + SB_sym = XSYMBOL (SB_symbol); \ + SB_oldval = SB_sym->value; \ + \ + if (!SYMBOL_VALUE_MAGIC_P (SB_oldval) || UNBOUNDP (SB_oldval)) \ + { \ + /* ### the following test will go away when we have a constant \ + symbol magic object */ \ + if (EQ (SB_symbol, Qnil) || \ + EQ (SB_symbol, Qt) || \ + SYMBOL_IS_KEYWORD (SB_symbol)) \ + reject_constant_symbols (SB_symbol, SB_newval, 0, \ + UNBOUNDP (SB_newval) ? \ + Qmakunbound : Qset); \ + \ + specpdl_ptr->symbol = SB_symbol; \ + specpdl_ptr->old_value = SB_oldval; \ + specpdl_ptr->func = 0; \ + specpdl_ptr++; \ + specpdl_depth_counter++; \ + \ + SB_sym->value = (SB_newval); \ + } \ + else \ + specbind_magic (SB_symbol, SB_newval); \ +} while (0) + +/* An even faster, but less safe inline version of specbind(). + Caller guarantees that: + - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword). + - specpdl_depth_counter >= specpdl_size. + Else we crash. */ +#define SPECBIND_FAST_UNSAFE(symbol_object, value_object) do { \ + Lisp_Object SFU_symbol = (symbol_object); \ + Lisp_Object SFU_newval = (value_object); \ + struct Lisp_Symbol *SFU_sym = XSYMBOL (SFU_symbol); \ + Lisp_Object SFU_oldval = SFU_sym->value; \ + if (!SYMBOL_VALUE_MAGIC_P (SFU_oldval) || UNBOUNDP (SFU_oldval)) \ + { \ + specpdl_ptr->symbol = SFU_symbol; \ + specpdl_ptr->old_value = SFU_oldval; \ + specpdl_ptr->func = 0; \ + specpdl_ptr++; \ + specpdl_depth_counter++; \ + \ + SFU_sym->value = (SFU_newval); \ + } \ + else \ + specbind_magic (SFU_symbol, SFU_newval); \ +} while (0) + +/* Request enough room for SIZE future entries on special binding stack */ +#define SPECPDL_RESERVE(size) do { \ + size_t SR_size = (size); \ + if (specpdl_depth() + SR_size >= specpdl_size) \ + grow_specpdl (SR_size); \ +} while (0) + +/* Inline version of unbind_to(). + Use this instead of unbind_to() if speed is sufficiently important + to save the overhead of even a single function call. + + Most of the time, unbind_to() is called only on ordinary + variables, so optimize for that. */ +#define UNBIND_TO_GCPRO(count, value) do { \ + int UNBIND_TO_count = (count); \ + while (specpdl_depth_counter != UNBIND_TO_count) \ + { \ + struct Lisp_Symbol *sym; \ + --specpdl_ptr; \ + --specpdl_depth_counter; \ + \ + if (specpdl_ptr->func != 0 || \ + ((sym = XSYMBOL (specpdl_ptr->symbol)), \ + SYMBOL_VALUE_MAGIC_P (sym->value))) \ + { \ + struct gcpro gcpro1; \ + GCPRO1 (value); \ + unbind_to_hairy (UNBIND_TO_count); \ + UNGCPRO; \ + break; \ + } \ + \ + sym->value = specpdl_ptr->old_value; \ + } \ +} while (0) + +/* A slightly faster inline version of unbind_to, + that doesn't offer GCPROing services. */ +#define UNBIND_TO(count) do { \ + int UNBIND_TO_count = (count); \ + while (specpdl_depth_counter != UNBIND_TO_count) \ + { \ + struct Lisp_Symbol *sym; \ + --specpdl_ptr; \ + --specpdl_depth_counter; \ + \ + if (specpdl_ptr->func != 0 || \ + ((sym = XSYMBOL (specpdl_ptr->symbol)), \ + SYMBOL_VALUE_MAGIC_P (sym->value))) \ + { \ + unbind_to_hairy (UNBIND_TO_count); \ + break; \ + } \ + \ + sym->value = specpdl_ptr->old_value; \ + } \ +} while (0) + +#ifdef ERROR_CHECK_TYPECHECK +#define CHECK_SPECBIND_VARIABLE assert (specpdl_ptr->func == 0) +#else +#define CHECK_SPECBIND_VARIABLE DO_NOTHING +#endif + +/* Another inline version of unbind_to(). VALUE is GC-protected. + Caller guarantees that: + - all of the elements on the binding stack are variable bindings. + Else we crash. */ +#define UNBIND_TO_GCPRO_VARIABLES_ONLY(count, value) do { \ + int UNBIND_TO_count = (count); \ + while (specpdl_depth_counter != UNBIND_TO_count) \ + { \ + struct Lisp_Symbol *sym; \ + --specpdl_ptr; \ + --specpdl_depth_counter; \ + \ + CHECK_SPECBIND_VARIABLE; \ + sym = XSYMBOL (specpdl_ptr->symbol); \ + if (!SYMBOL_VALUE_MAGIC_P (sym->value)) \ + sym->value = specpdl_ptr->old_value; \ + else \ + { \ + struct gcpro gcpro1; \ + GCPRO1 (value); \ + unbind_to_hairy (UNBIND_TO_count); \ + UNGCPRO; \ + break; \ + } \ + } \ +} while (0) + +/* A faster, but less safe inline version of Fset(). + Caller guarantees that: + - SYMBOL is a non-constant symbol (i.e. not Qnil, Qt, or keyword). + Else we crash. */ +#define FSET_FAST_UNSAFE(sym, newval) do { \ + Lisp_Object FFU_sym = (sym); \ + Lisp_Object FFU_newval = (newval); \ + struct Lisp_Symbol *FFU_symbol = XSYMBOL (FFU_sym); \ + Lisp_Object FFU_oldval = FFU_symbol->value; \ + if (!SYMBOL_VALUE_MAGIC_P (FFU_oldval) || UNBOUNDP (FFU_oldval)) \ + FFU_symbol->value = FFU_newval; \ + else \ + Fset (FFU_sym, FFU_newval); \ +} while (0) + #endif /* _XEMACS_BACKTRACE_H_ */ diff -r 76b7d63099ad -r 8626e4521993 src/balloon_help.c --- a/src/balloon_help.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/balloon_help.c Mon Aug 13 11:07:10 2007 +0200 @@ -32,7 +32,6 @@ #include #include -#include #include #include @@ -86,8 +85,6 @@ static CONST char* b_text; static int b_width, b_height; -static int b_lastX, b_lastY; - static XtIntervalId b_timer; static unsigned long b_delay; @@ -364,11 +361,8 @@ /* make sure it is still ok with offset */ shape = get_shape (shape, x, y, b_width, b_height, b_screenWidth, b_screenHeight); - b_lastX = x; - b_lastY = y; b_lastShape = shape; - make_mask (shape, x, y, b_width, b_height); XShapeCombineMask (b_dpy, b_win, ShapeBounding, 0, 0, b_mask, ShapeSet); @@ -598,9 +592,6 @@ if (shape == b_lastShape) { - b_lastX = x; - b_lastY = y; - XMoveWindow (b_dpy, b_win, shape & SHAPE_CONE_LEFT ? x : x - b_width, shape & SHAPE_CONE_TOP ? y : y - b_height); diff -r 76b7d63099ad -r 8626e4521993 src/buffer.c --- a/src/buffer.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/buffer.c Mon Aug 13 11:07:10 2007 +0200 @@ -80,6 +80,7 @@ #ifdef REGION_CACHE_NEEDS_WORK #include "region-cache.h" #endif +#include "specifier.h" #include "syntax.h" #include "sysdep.h" /* for getwd */ #include "window.h" @@ -227,13 +228,13 @@ undo_threshold, undo_high_threshold); -#define MARKED_SLOT(x) ((markobj) (buf->x)); +#define MARKED_SLOT(x) ((void) (markobj (buf->x))); #include "bufslots.h" #undef MARKED_SLOT - ((markobj) (buf->extent_info)); + markobj (buf->extent_info); if (buf->text) - ((markobj) (buf->text->line_number_cache)); + markobj (buf->text->line_number_cache); /* Don't mark normally through the children slot. (Actually, in this case, it doesn't matter.) */ @@ -310,12 +311,9 @@ */ (frame)) { - Lisp_Object list; - if (EQ (frame, Qt)) - list = Vbuffer_alist; - else - list = decode_frame (frame)->buffer_alist; - return Fmapcar (Qcdr, list); + return Fmapcar (Qcdr, + EQ (frame, Qt) ? Vbuffer_alist : + decode_frame (frame)->buffer_alist); } Lisp_Object @@ -435,7 +433,7 @@ (filename)) { /* This function can GC. GC checked 1997.04.06. */ - REGISTER Lisp_Object tail, buf, tem; + REGISTER Lisp_Object buf; struct gcpro gcpro1; #ifdef I18N3 @@ -476,18 +474,20 @@ NUNGCPRO; } - LIST_LOOP (tail, Vbuffer_alist) - { - buf = Fcdr (XCAR (tail)); - if (!BUFFERP (buf)) continue; - if (!STRINGP (XBUFFER (buf)->filename)) continue; - tem = Fstring_equal (filename, - (find_file_compare_truenames - ? XBUFFER (buf)->file_truename - : XBUFFER (buf)->filename)); - if (!NILP (tem)) - return buf; - } + { + Lisp_Object elt; + LIST_LOOP_2 (elt, Vbuffer_alist) + { + buf = Fcdr (elt); + if (!BUFFERP (buf)) continue; + if (!STRINGP (XBUFFER (buf)->filename)) continue; + if (!NILP (Fstring_equal (filename, + (find_file_compare_truenames + ? XBUFFER (buf)->file_truename + : XBUFFER (buf)->filename)))) + return buf; + } + } return Qnil; } @@ -579,8 +579,8 @@ init_buffer_markers (b); b->generated_modeline_string = Fmake_string (make_int (84), make_int (' ')); - b->modeline_extent_table = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQ); + b->modeline_extent_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, + HASH_TABLE_EQ); return buf; } @@ -2014,81 +2014,55 @@ delete_auto_save_files = 1; } -/* DOC is ignored because it is snagged and recorded externally - * by make-docfile */ +/* The docstrings for DEFVAR_* are recorded externally by make-docfile. */ + /* Renamed from DEFVAR_PER_BUFFER because FSFmacs D_P_B takes - * a bogus extra arg, which confuses an otherwise identical make-docfile.c */ + a bogus extra arg, which confuses an otherwise identical make-docfile.c */ + /* Declaring this stuff as const produces 'Cannot reinitialize' messages from SunPro C's fix-and-continue feature (a way neato feature that makes debugging unbelievably more bearable) */ -#define DEFVAR_BUFFER_LOCAL(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CURRENT_BUFFER_FORWARD }, 0 }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -#define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CURRENT_BUFFER_FORWARD }, magicfun }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -#define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, 0 }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -#define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) do{\ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_CONST_CURRENT_BUFFER_FORWARD }, magicfun }; \ - defvar_buffer_local ((lname), &I_hate_C); \ - } while (0) - -static void -defvar_buffer_local (CONST char *namestring, - CONST struct symbol_value_forward *m) -{ - int offset = ((char *)symbol_value_forward_forward (m) - - (char *)&buffer_local_flags); - - defvar_mumble (namestring, m, sizeof (*m)); - - *((Lisp_Object *)(offset + (char *)XBUFFER (Vbuffer_local_symbols))) - = intern (namestring); -} - -/* DOC is ignored because it is snagged and recorded externally - * by make-docfile */ -#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_BUFFER_FORWARD }, 0 }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) - -#define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) do { \ -static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ - = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ - SYMVAL_DEFAULT_BUFFER_FORWARD }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ - } while (0) +#define DEFVAR_BUFFER_LOCAL_1(lname, field_name, forward_type, magicfun) do { \ + static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ + = { { { symbol_value_forward_lheader_initializer, \ + (struct lcrecord_header *) &(buffer_local_flags.field_name), 69 }, \ + forward_type }, magicfun }; \ + { \ + int offset = ((char *)symbol_value_forward_forward (&I_hate_C) - \ + (char *)&buffer_local_flags); \ + defvar_magic (lname, &I_hate_C); \ + \ + *((Lisp_Object *)(offset + (char *)XBUFFER (Vbuffer_local_symbols))) \ + = intern (lname); \ + } \ +} while (0) + +#define DEFVAR_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \ + DEFVAR_BUFFER_LOCAL_1 (lname, field_name, \ + SYMVAL_CURRENT_BUFFER_FORWARD, magicfun) +#define DEFVAR_BUFFER_LOCAL(lname, field_name) \ + DEFVAR_BUFFER_LOCAL_MAGIC (lname, field_name, 0) +#define DEFVAR_CONST_BUFFER_LOCAL_MAGIC(lname, field_name, magicfun) \ + DEFVAR_BUFFER_LOCAL_1 (lname, field_name, \ + SYMVAL_CONST_CURRENT_BUFFER_FORWARD, magicfun) +#define DEFVAR_CONST_BUFFER_LOCAL(lname, field_name) \ + DEFVAR_CONST_BUFFER_LOCAL_MAGIC (lname, field_name, 0) + +#define DEFVAR_BUFFER_DEFAULTS_MAGIC(lname, field_name, magicfun) \ + DEFVAR_SYMVAL_FWD (lname, &(buffer_local_flags.field_name), \ + SYMVAL_DEFAULT_BUFFER_FORWARD, magicfun) +#define DEFVAR_BUFFER_DEFAULTS(lname, field_name) \ + DEFVAR_BUFFER_DEFAULTS_MAGIC (lname, field_name, 0) static void nuke_all_buffer_slots (struct buffer *b, Lisp_Object zap) { zero_lcrecord (b); + b->extent_info = Qnil; + b->indirect_children = Qnil; + b->own_text.line_number_cache = Qnil; + #define MARKED_SLOT(x) b->x = (zap); #include "bufslots.h" #undef MARKED_SLOT @@ -2117,15 +2091,17 @@ defs->major_mode = Qfundamental_mode; defs->mode_name = QSFundamental; defs->abbrev_table = Qnil; /* real default setup by Lisp code */ - defs->downcase_table = Vascii_downcase_table; - defs->upcase_table = Vascii_upcase_table; + + defs->downcase_table = Vascii_downcase_table; + defs->upcase_table = Vascii_upcase_table; defs->case_canon_table = Vascii_canon_table; - defs->case_eqv_table = Vascii_eqv_table; + defs->case_eqv_table = Vascii_eqv_table; #ifdef MULE - defs->mirror_downcase_table = Vmirror_ascii_downcase_table; - defs->mirror_upcase_table = Vmirror_ascii_upcase_table; + defs->mirror_downcase_table = Vmirror_ascii_downcase_table; + defs->mirror_upcase_table = Vmirror_ascii_upcase_table; defs->mirror_case_canon_table = Vmirror_ascii_canon_table; - defs->mirror_case_eqv_table = Vmirror_ascii_eqv_table; + defs->mirror_case_eqv_table = Vmirror_ascii_eqv_table; + defs->category_table = Vstandard_category_table; #endif /* MULE */ defs->syntax_table = Vstandard_syntax_table; @@ -2159,7 +2135,7 @@ */ Lisp_Object always_local_no_default = make_int (0); Lisp_Object always_local_resettable = make_int (-1); - Lisp_Object resettable = make_int (-3); + Lisp_Object resettable = make_int (-3); /* Assign the local-flags to the slots that have default values. The local flag is a bit that is used in the buffer @@ -2168,58 +2144,58 @@ 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.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.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; #if 0 /* FSFmacs */ - buffer_local_flags.mark_active = always_local_resettable; + buffer_local_flags.mark_active = always_local_resettable; #endif buffer_local_flags.point_before_scroll = always_local_resettable; - buffer_local_flags.file_truename = always_local_no_default; - buffer_local_flags.invisibility_spec = always_local_resettable; - buffer_local_flags.file_format = always_local_resettable; + buffer_local_flags.file_truename = always_local_no_default; + buffer_local_flags.invisibility_spec = always_local_resettable; + buffer_local_flags.file_format = always_local_resettable; buffer_local_flags.generated_modeline_string = always_local_no_default; - buffer_local_flags.keymap = resettable; - buffer_local_flags.downcase_table = resettable; - buffer_local_flags.upcase_table = resettable; + buffer_local_flags.keymap = resettable; + buffer_local_flags.downcase_table = resettable; + buffer_local_flags.upcase_table = resettable; buffer_local_flags.case_canon_table = resettable; - buffer_local_flags.case_eqv_table = resettable; - buffer_local_flags.syntax_table = resettable; + buffer_local_flags.case_eqv_table = resettable; + buffer_local_flags.syntax_table = resettable; #ifdef MULE - buffer_local_flags.category_table = resettable; + buffer_local_flags.category_table = resettable; #endif - buffer_local_flags.modeline_format = make_int (1); - buffer_local_flags.abbrev_mode = make_int (2); - buffer_local_flags.overwrite_mode = make_int (4); - buffer_local_flags.case_fold_search = make_int (8); - buffer_local_flags.auto_fill_function = make_int (0x10); - buffer_local_flags.selective_display = make_int (0x20); - buffer_local_flags.selective_display_ellipses = make_int (0x40); - buffer_local_flags.tab_width = make_int (0x80); - buffer_local_flags.truncate_lines = make_int (0x100); - buffer_local_flags.ctl_arrow = make_int (0x200); - buffer_local_flags.fill_column = make_int (0x400); - buffer_local_flags.left_margin = make_int (0x800); - buffer_local_flags.abbrev_table = make_int (0x1000); + buffer_local_flags.modeline_format = make_int (1<<0); + buffer_local_flags.abbrev_mode = make_int (1<<1); + buffer_local_flags.overwrite_mode = make_int (1<<2); + buffer_local_flags.case_fold_search = make_int (1<<3); + buffer_local_flags.auto_fill_function = make_int (1<<4); + buffer_local_flags.selective_display = make_int (1<<5); + buffer_local_flags.selective_display_ellipses = make_int (1<<6); + buffer_local_flags.tab_width = make_int (1<<7); + buffer_local_flags.truncate_lines = make_int (1<<8); + buffer_local_flags.ctl_arrow = make_int (1<<9); + buffer_local_flags.fill_column = make_int (1<<10); + buffer_local_flags.left_margin = make_int (1<<11); + buffer_local_flags.abbrev_table = make_int (1<<12); #ifdef REGION_CACHE_NEEDS_WORK - buffer_local_flags.cache_long_line_scans = make_int (0x2000); + buffer_local_flags.cache_long_line_scans = make_int (1<<13); #endif #ifdef FILE_CODING - buffer_local_flags.buffer_file_coding_system = make_int (0x4000); + buffer_local_flags.buffer_file_coding_system = make_int (1<<14); #endif - /* #### Warning, 0x4000000 (that's six zeroes) is the largest number - currently allowable due to the XINT() handling of this value. - With some rearrangement you can get 4 more bits. */ + /* #### Warning: 1<<28 is the largest number currently allowable + due to the XINT() handling of this value. With some + rearrangement you can get 3 more bits. */ } DEFVAR_BUFFER_DEFAULTS ("default-modeline-format", modeline_format /* @@ -2429,7 +2405,7 @@ The default value for this variable (which is normally used for buffers without associated files) is also used when automatic detection of a file's encoding is called for and there was no -discernable encoding in the file (i.e. it was entirely or almost +discernible encoding in the file (i.e. it was entirely or almost entirely ASCII). The default value should generally *not* be set to nil (equivalent to `no-conversion'), because if extended characters are ever inserted into the buffer, they will be lost when the file is @@ -2457,7 +2433,7 @@ variables just mentioned, which are intended to be used for global environment specification. */ ); -#endif +#endif /* FILE_CODING */ DEFVAR_BUFFER_LOCAL ("auto-fill-function", auto_fill_function /* Function called (if non-nil) to perform auto-fill. @@ -2744,7 +2720,7 @@ initial_directory[rc + 1] = '\0'; } /* XEmacs change: store buffer's default directory - using prefered (i.e. as defined at compile-time) + using preferred (i.e. as defined at compile-time) directory separator. --marcpa */ #ifdef DOS_NT #define CORRECT_DIR_SEPS(s) \ diff -r 76b7d63099ad -r 8626e4521993 src/buffer.h --- a/src/buffer.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/buffer.h Mon Aug 13 11:07:10 2007 +0200 @@ -237,6 +237,7 @@ x = wrong_type_argument (Qbuffer_live_p, (x)); \ } while (0) + #define BUFFER_BASE_BUFFER(b) ((b)->base_buffer ? (b)->base_buffer : (b)) /* Map over buffers sharing the same text as MPS_BUF. MPS_BUFVAR is a @@ -255,6 +256,13 @@ ) + +/************************************************************************/ +/* */ +/* working with raw internal-format data */ +/* */ +/************************************************************************/ + /* NOTE: In all the following macros, we follow these rules concerning multiple evaluation of the arguments: @@ -270,52 +278,44 @@ denoted with the word "unsafe" in their name and are generally meant to be called only by other macros that have already stored the calling values in temporary variables. - */ + -/************************************************************************/ -/* */ -/* working with raw internal-format data */ -/* */ -/************************************************************************/ - -/* Use these on contiguous strings of data. If the text you're - operating on is known to come from a buffer, use the buffer-level - functions below -- they know about the gap and may be more - efficient. */ - -/* Functions are as follows: + Use the following functions/macros on contiguous strings of data. + If the text you're operating on is known to come from a buffer, use + the buffer-level functions below -- they know about the gap and may + be more efficient. - (A) For working with charptr's (pointers to internally-formatted text): - ----------------------------------------------------------------------- + (A) For working with charptr's (pointers to internally-formatted text): + ----------------------------------------------------------------------- - VALID_CHARPTR_P(ptr): + VALID_CHARPTR_P (ptr): Given a charptr, does it point to the beginning of a character? - ASSERT_VALID_CHARPTR(ptr): + ASSERT_VALID_CHARPTR (ptr): If error-checking is enabled, assert that the given charptr - points to the beginning of a character. Otherwise, do nothing. + points to the beginning of a character. Otherwise, do nothing. - INC_CHARPTR(ptr): + INC_CHARPTR (ptr): Given a charptr (assumed to point at the beginning of a character), modify that pointer so it points to the beginning of the next character. - DEC_CHARPTR(ptr): + DEC_CHARPTR (ptr): Given a charptr (assumed to point at the beginning of a character or at the very end of the text), modify that pointer so it points to the beginning of the previous character. - VALIDATE_CHARPTR_BACKWARD(ptr): + VALIDATE_CHARPTR_BACKWARD (ptr): Make sure that PTR is pointing to the beginning of a character. - If not, back up until this is the case. Note that there are not + If not, back up until this is the case. Note that there are not too many places where it is legitimate to do this sort of thing. It's an error if you're passed an "invalid" char * pointer. NOTE: PTR *must* be pointing to a valid part of the string (i.e. not the very end, unless the string is zero-terminated or something) in order for this function to not cause crashes. - VALIDATE_CHARPTR_FORWARD(ptr): + VALIDATE_CHARPTR_FORWARD (ptr): Make sure that PTR is pointing to the beginning of a character. If not, move forward until this is the case. Note that there are not too many places where it is legitimate to do this sort @@ -327,38 +327,34 @@ section of internally-formatted text: -------------------------------------------------------------- - bytecount_to_charcount(ptr, nbi): + bytecount_to_charcount (ptr, nbi): Given a pointer to a text string and a length in bytes, return the equivalent length in characters. - charcount_to_bytecount(ptr, nch): + charcount_to_bytecount (ptr, nch): Given a pointer to a text string and a length in characters, return the equivalent length in bytes. - charptr_n_addr(ptr, n): + charptr_n_addr (ptr, n): Return a pointer to the beginning of the character offset N (in characters) from PTR. - charptr_length(ptr): - Given a zero-terminated pointer to Emacs characters, - return the number of Emacs characters contained within. - (C) For retrieving or changing the character pointed to by a charptr: --------------------------------------------------------------------- - charptr_emchar(ptr): + charptr_emchar (ptr): Retrieve the character pointed to by PTR as an Emchar. - charptr_emchar_n(ptr, n): + charptr_emchar_n (ptr, n): Retrieve the character at offset N (in characters) from PTR, as an Emchar. - set_charptr_emchar(ptr, ch): + set_charptr_emchar (ptr, ch): Store the character CH (an Emchar) as internally-formatted text starting at PTR. Return the number of bytes stored. - charptr_copy_char(ptr, ptr2): + charptr_copy_char (ptr, ptr2): Retrieve the character pointed to by PTR and store it as internally-formatted text in PTR2. @@ -370,25 +366,16 @@ 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.) + CHARP (ch): + Return whether the given Lisp_Object is a character. - 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.) - - COERCE_CHAR(ch): - Coerce an object that is known to satisfy CHARP() into a - valid Emchar. + CHECK_CHAR_COERCE_INT (ch): + Signal an error if CH is not a valid character or integer Lisp_Object. + If CH is an integer Lisp_Object, convert it to a character Lisp_Object, + but merely by repackaging, without performing tests for char validity. MAX_EMCHAR_LEN: Maximum number of buffer bytes per Emacs character. @@ -419,38 +406,32 @@ 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) (real_inc_charptr_fun (ptr))) - -#define INC_CHARPTR(ptr) do { \ - ASSERT_VALID_CHARPTR (ptr); \ - REAL_INC_CHARPTR (ptr); \ -} while (0) +#define REAL_INC_CHARPTR(ptr) \ + ((void) ((ptr) += REP_BYTES_BY_FIRST_BYTE (* (unsigned char *) (ptr)))) #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 INC_CHARPTR(ptr) do { \ + ASSERT_VALID_CHARPTR (ptr); \ + REAL_INC_CHARPTR (ptr); \ } while (0) -#else + +#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 /* ! ERROR_CHECK_BUFPOS */ +#define INC_CHARPTR(ptr) REAL_INC_CHARPTR (ptr) #define DEC_CHARPTR(ptr) REAL_DEC_CHARPTR (ptr) -#endif +#endif /* ! ERROR_CHECK_BUFPOS */ #ifdef MULE @@ -462,11 +443,11 @@ the end of the string. */ #define VALIDATE_CHARPTR_FORWARD(ptr) do { \ - Bufbyte *__vcfptr__ = (ptr); \ - VALIDATE_CHARPTR_BACKWARD (__vcfptr__); \ - if (__vcfptr__ != (ptr)) \ + Bufbyte *vcf_ptr = (ptr); \ + VALIDATE_CHARPTR_BACKWARD (vcf_ptr); \ + if (vcf_ptr != (ptr)) \ { \ - (ptr) = __vcfptr__; \ + (ptr) = vcf_ptr; \ INC_CHARPTR (ptr); \ } \ } while (0) @@ -488,14 +469,6 @@ return ptr + charcount_to_bytecount (ptr, offset); } -INLINE Charcount charptr_length (CONST Bufbyte *ptr); -INLINE Charcount -charptr_length (CONST Bufbyte *ptr) -{ - return bytecount_to_charcount (ptr, strlen ((CONST char *) ptr)); -} - - /* -------------------------------------------------------------------- */ /* (C) For retrieving or changing the character pointed to by a charptr */ /* -------------------------------------------------------------------- */ @@ -561,12 +534,12 @@ INLINE int valid_char_p (Emchar ch) { - return (ch >= 0 && ch <= 255) || non_ascii_valid_char_p (ch); + return ((unsigned int) (ch) <= 0xff) || non_ascii_valid_char_p (ch); } #else /* not MULE */ -#define valid_char_p(ch) ((unsigned int) (ch) <= 255) +#define valid_char_p(ch) ((unsigned int) (ch) <= 0xff) #endif /* not MULE */ @@ -869,11 +842,10 @@ results with stupid compilers. */ #ifdef MULE -# define VALIDATE_BYTIND_BACKWARD(buf, x) do \ -{ \ - Bufbyte *__ibptr = BI_BUF_BYTE_ADDRESS (buf, x); \ - while (!BUFBYTE_FIRST_BYTE_P (*__ibptr)) \ - __ibptr--, (x)--; \ +# define VALIDATE_BYTIND_BACKWARD(buf, x) do { \ + Bufbyte *VBB_ptr = BI_BUF_BYTE_ADDRESS (buf, x); \ + while (!BUFBYTE_FIRST_BYTE_P (*VBB_ptr)) \ + VBB_ptr--, (x)--; \ } while (0) #else # define VALIDATE_BYTIND_BACKWARD(buf, x) @@ -885,11 +857,10 @@ results with stupid compilers. */ #ifdef MULE -# define VALIDATE_BYTIND_FORWARD(buf, x) do \ -{ \ - Bufbyte *__ibptr = BI_BUF_BYTE_ADDRESS (buf, x); \ - while (!BUFBYTE_FIRST_BYTE_P (*__ibptr)) \ - __ibptr++, (x)++; \ +# define VALIDATE_BYTIND_FORWARD(buf, x) do { \ + Bufbyte *VBF_ptr = BI_BUF_BYTE_ADDRESS (buf, x); \ + while (!BUFBYTE_FIRST_BYTE_P (*VBF_ptr)) \ + VBF_ptr++, (x)++; \ } while (0) #else # define VALIDATE_BYTIND_FORWARD(buf, x) @@ -1162,7 +1133,7 @@ Extcount gceda_len_out; \ CONST Bufbyte *gceda_ptr_in = (ptr); \ Extbyte *gceda_ptr_out = \ - convert_to_external_format (gceda_ptr_in, gceda_len_in, \ + convert_to_external_format (gceda_ptr_in, gceda_len_in, \ &gceda_len_out, fmt); \ /* If the new string is identical to the old (will be the case most \ of the time), just return the same string back. This saves \ @@ -1173,14 +1144,13 @@ !memcmp (gceda_ptr_in, gceda_ptr_out, gceda_len_out)) \ { \ (ptr_out) = (Extbyte *) gceda_ptr_in; \ - (len_out) = (Extcount) gceda_len_in; \ } \ else \ { \ (ptr_out) = (Extbyte *) alloca (1 + gceda_len_out); \ memcpy ((void *) ptr_out, gceda_ptr_out, 1 + gceda_len_out); \ - (len_out) = (Extcount) gceda_len_out; \ } \ + (len_out) = gceda_len_out; \ } while (0) #else /* ! MULE */ @@ -1240,9 +1210,9 @@ { \ Extcount gcida_len_in = (Extcount) (len); \ Bytecount gcida_len_out; \ - CONST Extbyte *gcida_ptr_in = (ptr); \ + CONST Extbyte *gcida_ptr_in = (ptr); \ Bufbyte *gcida_ptr_out = \ - convert_from_external_format (gcida_ptr_in, gcida_len_in, \ + convert_from_external_format (gcida_ptr_in, gcida_len_in, \ &gcida_len_out, fmt); \ /* If the new string is identical to the old (will be the case most \ of the time), just return the same string back. This saves \ @@ -1253,14 +1223,13 @@ !memcmp (gcida_ptr_in, gcida_ptr_out, gcida_len_out)) \ { \ (ptr_out) = (Bufbyte *) gcida_ptr_in; \ - (len_out) = (Bytecount) gcida_len_in; \ } \ else \ { \ (ptr_out) = (Extbyte *) alloca (1 + gcida_len_out); \ memcpy ((void *) ptr_out, gcida_ptr_out, 1 + gcida_len_out); \ - (len_out) = gcida_len_out; \ } \ + (len_out) = gcida_len_out; \ } while (0) #else /* ! MULE */ @@ -1604,7 +1573,7 @@ #else /* !REL_ALLOC */ #define BUFFER_ALLOC(data,size)\ - ((void) (data = xnew_array (Bufbyte, size))) + (data = xnew_array (Bufbyte, size)) #define BUFFER_REALLOC(data,size)\ ((Bufbyte *) xrealloc (data, (size) * sizeof(Bufbyte))) /* Avoid excess parentheses, or syntax errors may rear their heads. */ @@ -1634,9 +1603,9 @@ void convert_bufbyte_string_into_emchar_dynarr (CONST Bufbyte *str, Bytecount len, Emchar_dynarr *dyn); -int convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, - Bytecount len, - Emchar *arr); +Charcount convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, + Bytecount len, + Emchar *arr); void convert_emchar_string_into_bufbyte_dynarr (Emchar *arr, int nels, Bufbyte_dynarr *dyn); Bufbyte *convert_emchar_string_into_malloced_string (Emchar *arr, int nels, @@ -1713,9 +1682,9 @@ typically used to convert between uppercase and lowercase. For compatibility reasons, trt tables are currently in the form of a Lisp string of 256 characters, specifying the conversion for each - of the first 256 Emacs characters (i.e. the 256 extended-ASCII - characters). This should be generalized at some point to support - conversions for all of the allowable Mule characters. + of the first 256 Emacs characters (i.e. the 256 Latin-1 characters). + This should be generalized at some point to support conversions for + all of the allowable Mule characters. */ /* The _1 macros are named as such because they assume that you have @@ -1808,7 +1777,7 @@ return (DOWNCASE_TABLE_OF (buf, ch) == ch) ? UPCASE_TABLE_OF (buf, ch) : ch; } -/* Upcase a character known to be not upper case. */ +/* Upcase a character known to be not upper case. Unused. */ #define UPCASE1(buf, ch) UPCASE_TABLE_OF (buf, ch) diff -r 76b7d63099ad -r 8626e4521993 src/bufslots.h --- a/src/bufslots.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/bufslots.h Mon Aug 13 11:07:10 2007 +0200 @@ -69,7 +69,7 @@ Specifically, this lists those variables that have a buffer-local value in this buffer: i.e. those whose value does not shadow the default value. - (Remember that for any particlar variable created + (Remember that for any particular variable created with `make-local-variable' or `make-variable-buffer-local', it will have a per-buffer value in some buffers and a default value in others.) diff -r 76b7d63099ad -r 8626e4521993 src/bytecode.c --- a/src/bytecode.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/bytecode.c Mon Aug 13 11:07:10 2007 +0200 @@ -1,4 +1,5 @@ /* Execution of byte code produced by bytecomp.el. + Implementation of compiled-function objects. Copyright (C) 1992, 1993 Free Software Foundation, Inc. This file is part of XEmacs. @@ -27,7 +28,7 @@ FSF: long ago. -hacked on by jwz@netscape.com 17-jun-91 +hacked on by jwz@netscape.com 1991-06 o added a compile-time switch to turn on simple sanity checking; o put back the obsolete byte-codes for error-detection; o added a new instruction, unbind_all, which I will use for @@ -41,25 +42,198 @@ o added relative jump instructions; o all conditionals now only do QUIT if they jump. - Ben Wing: some changes for Mule, June 1995. + Ben Wing: some changes for Mule, 1995-06. + + Martin Buchholz: performance hacking, 1998-09. + See Internals Manual, Evaluation. */ #include #include "lisp.h" +#include "backtrace.h" #include "buffer.h" +#include "bytecode.h" +#include "opaque.h" #include "syntax.h" -/* - * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for - * debugging the byte compiler...) Somewhat surprisingly, defining this - * makes Fbyte_code about 8% slower. - * - * define BYTE_CODE_METER to enable generation of a byte-op usage histogram. - */ -/* This isn't defined in FSF Emacs and isn't defined in XEmacs v19 */ +#include +#include + +EXFUN (Ffetch_bytecode, 1); + +Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code; + +enum Opcode /* Byte codes */ +{ + Bvarref = 010, + Bvarset = 020, + Bvarbind = 030, + Bcall = 040, + Bunbind = 050, + + Bnth = 070, + Bsymbolp = 071, + Bconsp = 072, + Bstringp = 073, + Blistp = 074, + Bold_eq = 075, + Bold_memq = 076, + Bnot = 077, + Bcar = 0100, + Bcdr = 0101, + Bcons = 0102, + Blist1 = 0103, + Blist2 = 0104, + Blist3 = 0105, + Blist4 = 0106, + Blength = 0107, + Baref = 0110, + Baset = 0111, + Bsymbol_value = 0112, + Bsymbol_function = 0113, + Bset = 0114, + Bfset = 0115, + Bget = 0116, + Bsubstring = 0117, + Bconcat2 = 0120, + Bconcat3 = 0121, + Bconcat4 = 0122, + Bsub1 = 0123, + Badd1 = 0124, + Beqlsign = 0125, + Bgtr = 0126, + Blss = 0127, + Bleq = 0130, + Bgeq = 0131, + Bdiff = 0132, + Bnegate = 0133, + Bplus = 0134, + Bmax = 0135, + Bmin = 0136, + Bmult = 0137, + + Bpoint = 0140, + Beq = 0141, /* was Bmark, + but no longer generated as of v18 */ + Bgoto_char = 0142, + Binsert = 0143, + Bpoint_max = 0144, + Bpoint_min = 0145, + Bchar_after = 0146, + Bfollowing_char = 0147, + Bpreceding_char = 0150, + Bcurrent_column = 0151, + Bindent_to = 0152, + Bequal = 0153, /* was Bscan_buffer, + but no longer generated as of v18 */ + Beolp = 0154, + Beobp = 0155, + Bbolp = 0156, + Bbobp = 0157, + Bcurrent_buffer = 0160, + Bset_buffer = 0161, + Bsave_current_buffer = 0162, /* was Bread_char, + but no longer generated as of v19 */ + Bmemq = 0163, /* was Bset_mark, + but no longer generated as of v18 */ + Binteractive_p = 0164, /* Needed since interactive-p takes + unevalled args */ + Bforward_char = 0165, + Bforward_word = 0166, + Bskip_chars_forward = 0167, + Bskip_chars_backward = 0170, + Bforward_line = 0171, + Bchar_syntax = 0172, + Bbuffer_substring = 0173, + Bdelete_region = 0174, + Bnarrow_to_region = 0175, + Bwiden = 0176, + Bend_of_line = 0177, + + Bconstant2 = 0201, + Bgoto = 0202, + Bgotoifnil = 0203, + Bgotoifnonnil = 0204, + Bgotoifnilelsepop = 0205, + Bgotoifnonnilelsepop = 0206, + Breturn = 0207, + Bdiscard = 0210, + Bdup = 0211, + + Bsave_excursion = 0212, + Bsave_window_excursion= 0213, + Bsave_restriction = 0214, + Bcatch = 0215, + + Bunwind_protect = 0216, + Bcondition_case = 0217, + Btemp_output_buffer_setup = 0220, + Btemp_output_buffer_show = 0221, + + Bunbind_all = 0222, + + Bset_marker = 0223, + Bmatch_beginning = 0224, + Bmatch_end = 0225, + Bupcase = 0226, + Bdowncase = 0227, + + Bstring_equal = 0230, + Bstring_lessp = 0231, + Bold_equal = 0232, + Bnthcdr = 0233, + Belt = 0234, + Bold_member = 0235, + Bold_assq = 0236, + Bnreverse = 0237, + Bsetcar = 0240, + Bsetcdr = 0241, + Bcar_safe = 0242, + Bcdr_safe = 0243, + Bnconc = 0244, + Bquo = 0245, + Brem = 0246, + Bnumberp = 0247, + Bintegerp = 0250, + + BRgoto = 0252, + BRgotoifnil = 0253, + BRgotoifnonnil = 0254, + BRgotoifnilelsepop = 0255, + BRgotoifnonnilelsepop = 0256, + + BlistN = 0257, + BconcatN = 0260, + BinsertN = 0261, + Bmember = 0266, /* new in v20 */ + Bassq = 0267, /* new in v20 */ + + Bconstant = 0300 +}; +typedef enum Opcode Opcode; +typedef unsigned char Opbyte; + + +static void invalid_byte_code_error (char *error_message, ...); + +Lisp_Object * execute_rare_opcode (Lisp_Object *stack_ptr, + CONST Opbyte *program_ptr, + Opcode opcode); + +static Lisp_Object execute_optimized_program (CONST Opbyte *program, + int stack_depth, + Lisp_Object *constants_data); + +extern Lisp_Object Qand_rest, Qand_optional; + +/* Define ERROR_CHECK_BYTE_CODE to enable some minor sanity checking. + Useful for debugging the byte compiler. */ #ifdef DEBUG_XEMACS -#define BYTE_CODE_SAFE +#define ERROR_CHECK_BYTE_CODE #endif + +/* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram. + This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */ /* #define BYTE_CODE_METER */ @@ -73,546 +247,644 @@ #define METER_1(code) METER_2 (0, (code)) -#define METER_CODE(last_code, this_code) \ -{ \ - if (byte_metering_on) \ - { \ - if (METER_1 (this_code) != ((1< ival2 ? 1 : 0; + } + + arithcompare_float: + + { + double dval1, dval2; + + if (FLOATP (obj1)) dval1 = XFLOAT_DATA (obj1); + else if (INTP (obj1)) dval1 = (double) XINT (obj1); + else if (CHARP (obj1)) dval1 = (double) XCHAR (obj1); + else if (MARKERP (obj1)) dval1 = (double) marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (FLOATP (obj2)) dval2 = XFLOAT_DATA (obj2); + else if (INTP (obj2)) dval2 = (double) XINT (obj2); + else if (CHARP (obj2)) dval2 = (double) XCHAR (obj2); + else if (MARKERP (obj2)) dval2 = (double) marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; + } +#else /* !LISP_FLOAT_TYPE */ + { + int ival1, ival2; + + if (INTP (obj1)) ival1 = XINT (obj1); + else if (CHARP (obj1)) ival1 = XCHAR (obj1); + else if (MARKERP (obj1)) ival1 = marker_position (obj1); + else + { + obj1 = wrong_type_argument (Qnumber_char_or_marker_p, obj1); + goto retry; + } + + if (INTP (obj2)) ival2 = XINT (obj2); + else if (CHARP (obj2)) ival2 = XCHAR (obj2); + else if (MARKERP (obj2)) ival2 = marker_position (obj2); + else + { + obj2 = wrong_type_argument (Qnumber_char_or_marker_p, obj2); + goto retry; + } + + return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0; + } +#endif /* !LISP_FLOAT_TYPE */ } -#endif /* no BYTE_CODE_METER */ - +static Lisp_Object +bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) +{ +#ifdef LISP_FLOAT_TYPE + int ival1, ival2; + int float_p; -Lisp_Object Qbyte_code; + retry: + + float_p = 0; -/* Byte codes: */ + 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; + } -#define Bvarref 010 -#define Bvarset 020 -#define Bvarbind 030 -#define Bcall 040 -#define Bunbind 050 + 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; + } -#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 + 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; -#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 */ + retry: + + 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; + } -#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 + 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; -#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 + 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); -#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 + /* 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); + } -#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 + if (i < nargs) + goto wrong_number_of_arguments; + + run_code: + + { + Lisp_Object value = + execute_optimized_program ((Opbyte *) XOPAQUE_DATA (f->instructions), + f->stack_depth, + XVECTOR_DATA (f->constants)); + + UNBIND_TO_GCPRO_VARIABLES_ONLY (speccount, value); + return value; + } + + wrong_number_of_arguments: + return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); +} + + +/* Read next uint8 from the instruction stream. */ +#define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++) + +/* Read next uint16 from the instruction stream. */ +#define READ_UINT_2 \ + (program_ptr += 2, \ + (((unsigned int) (unsigned char) program_ptr[-1]) * 256 + \ + ((unsigned int) (unsigned char) program_ptr[-2]))) -#define BRgoto 0252 -#define BRgotoifnil 0253 -#define BRgotoifnonnil 0254 -#define BRgotoifnilelsepop 0255 -#define BRgotoifnonnilelsepop 0256 +/* Read next int8 from the instruction stream. */ +#define READ_INT_1 ((int) (signed char) *program_ptr++) -#define BlistN 0257 -#define BconcatN 0260 -#define BinsertN 0261 -#define Bmember 0266 /* new in v20 */ -#define Bassq 0267 /* new in v20 */ +/* 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]) -#define Bconstant 0300 -#define CONSTANTLIM 0100 - -/* Fetch the next byte from the bytecode stream */ +/* 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])) -#define FETCH (massaged_code[pc++]) +/* 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) -/* Fetch two bytes from the bytecode stream - and make a 16-bit number out of them */ +#define JUMP JUMP_RELATIVE (PEEK_INT_2) +#define JUMPR JUMP_RELATIVE (PEEK_INT_1) -#define FETCH2 (op = FETCH, op + (FETCH << 8)) +#define JUMP_NEXT ((void) (program_ptr += 2)) +#define JUMPR_NEXT ((void) (program_ptr += 1)) /* Push x onto the execution stack. */ - -#define PUSH(x) (*++stackp = (x)) +#define PUSH(x) (*++stack_ptr = (x)) -/* Pop a value off the execution stack. */ - -#define POP (*stackp--) +/* Pop a value off the execution stack. */ +#define POP (*stack_ptr--) /* Discard n values from the execution stack. */ - -#define DISCARD(n) (stackp -= (n)) +#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 (*stackp) +#define TOP (*stack_ptr) -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)) +/* 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 */ + + +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); -#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); +#ifdef ERROR_CHECK_BYTE_CODE + Lisp_Object *stack_beg = stack_ptr; + Lisp_Object *stack_end = stack_beg + stack_depth; +#endif - --stackp; - stack = stackp; - stacke = stackp + XINT (maxdepth); + /* 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; + } - /* 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; + 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 - { - case Bvarref+6: - op = FETCH; - goto varref; - case Bvarref+7: - op = FETCH2; - goto varref; + switch (opcode) + { + REGISTER int n; - 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); + 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 Bvarset+6: - op = FETCH; - goto varset; - - case Bvarset+7: - op = FETCH2; - goto varset; + 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: case Bvarset+1: case Bvarset+2: case Bvarset+3: - case Bvarset+4: case Bvarset+5: - op -= Bvarset; - varset: - Fset (vectorp[op], POP); + case Bvarset: + case Bvarset+1: + case Bvarset+2: + case Bvarset+3: + case Bvarset+4: + case Bvarset+5: n = opcode - Bvarset; goto do_varset; + case Bvarset+7: n = READ_UINT_2; goto do_varset; + case Bvarset+6: n = READ_UINT_1; /* most common */ + do_varset: + { + Lisp_Object symbol = constants_data[n]; + struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); + Lisp_Object old_value = symbol_ptr->value; + Lisp_Object new_value = POP; + if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) + symbol_ptr->value = new_value; + else + Fset (symbol, new_value); break; - - case Bvarbind+6: - op = FETCH; - goto varbind; + } - case Bvarbind+7: - op = FETCH2; - goto varbind; + case Bvarbind: + case Bvarbind+1: + case Bvarbind+2: + case Bvarbind+3: + case Bvarbind+4: + case Bvarbind+5: n = opcode - Bvarbind; goto do_varbind; + case Bvarbind+7: n = READ_UINT_2; goto do_varbind; + case Bvarbind+6: n = READ_UINT_1; /* most common */ + do_varbind: + { + Lisp_Object symbol = constants_data[n]; + struct Lisp_Symbol *symbol_ptr = XSYMBOL (symbol); + Lisp_Object old_value = symbol_ptr->value; + Lisp_Object new_value = POP; + if (!SYMBOL_VALUE_MAGIC_P (old_value) || UNBOUNDP (old_value)) + { + specpdl_ptr->symbol = symbol; + specpdl_ptr->old_value = old_value; + specpdl_ptr->func = 0; + specpdl_ptr++; + specpdl_depth_counter++; - case Bvarbind: case Bvarbind+1: case Bvarbind+2: case Bvarbind+3: - case Bvarbind+4: case Bvarbind+5: - op -= Bvarbind; - varbind: - specbind (vectorp[op], POP); + symbol_ptr->value = new_value; + } + else + specbind_magic (symbol, new_value); break; + } + case Bcall: + case Bcall+1: + case Bcall+2: + case Bcall+3: + case Bcall+4: + case Bcall+5: case Bcall+6: - op = FETCH; - goto docall; - case Bcall+7: - op = FETCH2; - goto docall; - - case Bcall: case Bcall+1: case Bcall+2: case Bcall+3: - case Bcall+4: case Bcall+5: - op -= Bcall; - docall: - DISCARD (op); + n = (opcode < Bcall+6 ? opcode - Bcall : + opcode == Bcall+6 ? READ_UINT_1 : READ_UINT_2); + DISCARD (n); #ifdef BYTE_CODE_METER if (byte_metering_on && SYMBOLP (TOP)) { - v1 = TOP; - v2 = Fget (v1, Qbyte_code_meter, Qnil); - if (INTP (v2) - && XINT (v2) != ((1< 0 ? Qt : Qnil; + break; + } case Blss: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_less); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) < 0 ? Qt : Qnil; + break; + } case Bleq: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_less_or_equal); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) <= 0 ? Qt : Qnil; + break; + } case Bgeq: - v1 = POP; - TOP = arithcompare (TOP, v1, arith_grtr_or_equal); - break; + { + Lisp_Object arg = POP; + TOP = bytecode_arithcompare (TOP, arg) >= 0 ? Qt : Qnil; + break; + } - case Bdiff: - DISCARD (1); - TOP = Fminus (2, &TOP); + + case Bnegate: + TOP = bytecode_negate (TOP); break; - case Bnegate: - v1 = TOP; - if (INTP (v1)) - { - XSETINT (v1, - XINT (v1)); - TOP = v1; - } - else - TOP = Fminus (1, &TOP); + case Bnconc: + DISCARD (1); + TOP = bytecode_nconc2 (&TOP); break; case Bplus: - DISCARD (1); - TOP = Fplus (2, &TOP); - break; + { + 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 Bmax: - DISCARD (1); - TOP = Fmax (2, &TOP); - 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); - break; - - case Brem: - v1 = POP; - TOP = Frem (TOP, v1); - break; + case Bmax: + case Bmin: + { + Lisp_Object arg = POP; + TOP = bytecode_arithop (TOP, arg, opcode); + break; + } case Bpoint: - v1 = make_int (BUF_PT (current_buffer)); - PUSH (v1); - break; - - case Bgoto_char: - TOP = Fgoto_char (TOP, Qnil); + PUSH (make_int (BUF_PT (current_buffer))); break; case Binsert: @@ -889,303 +1092,1339 @@ break; case BinsertN: - op = FETCH; - DISCARD (op - 1); - TOP = Finsert (op, &TOP); - break; - - case Bpoint_max: - v1 = make_int (BUF_ZV (current_buffer)); - PUSH (v1); - break; - - case Bpoint_min: - v1 = make_int (BUF_BEGV (current_buffer)); - PUSH (v1); - break; - - case Bchar_after: - TOP = Fchar_after (TOP, Qnil); - break; - - case Bfollowing_char: - v1 = Ffollowing_char (Qnil); - PUSH (v1); + n = READ_UINT_1; + DISCARD (n - 1); + TOP = Finsert (n, &TOP); break; - case Bpreceding_char: - v1 = Fpreceding_char (Qnil); - PUSH (v1); - break; + case Baref: + { + Lisp_Object arg = POP; + TOP = Faref (TOP, arg); + break; + } - case Bcurrent_column: - v1 = make_int (current_column (current_buffer)); - PUSH (v1); - break; + case Bmemq: + { + Lisp_Object arg = POP; + TOP = Fmemq (TOP, arg); + break; + } - case Bindent_to: - TOP = Findent_to (TOP, Qnil, Qnil); - break; + + case Bset: + { + Lisp_Object arg = POP; + TOP = Fset (TOP, arg); + break; + } - case Beolp: - PUSH (Feolp (Qnil)); - break; + case Bequal: + { + Lisp_Object arg = POP; + TOP = Fequal (TOP, arg); + break; + } + + case Bnthcdr: + { + Lisp_Object arg = POP; + TOP = Fnthcdr (TOP, arg); + break; + } - case Beobp: - PUSH (Feobp (Qnil)); - break; + case Belt: + { + Lisp_Object arg = POP; + TOP = Felt (TOP, arg); + break; + } - case Bbolp: - PUSH (Fbolp (Qnil)); - break; + case Bmember: + { + Lisp_Object arg = POP; + TOP = Fmember (TOP, arg); + break; + } - case Bbobp: - PUSH (Fbobp (Qnil)); + case Bgoto_char: + TOP = Fgoto_char (TOP, Qnil); break; case Bcurrent_buffer: - PUSH (Fcurrent_buffer ()); - break; + { + Lisp_Object buffer; + XSETBUFFER (buffer, current_buffer); + PUSH (buffer); + break; + } case Bset_buffer: TOP = Fset_buffer (TOP); break; - case Bsave_current_buffer: - record_unwind_protect (save_current_buffer_restore, - Fcurrent_buffer ()); + case Bpoint_max: + PUSH (make_int (BUF_ZV (current_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); + case Bpoint_min: + PUSH (make_int (BUF_BEGV (current_buffer))); break; case Bskip_chars_forward: - v1 = POP; - TOP = Fskip_chars_forward (TOP, v1, Qnil); - break; - - case Bskip_chars_backward: - v1 = POP; - TOP = Fskip_chars_backward (TOP, v1, Qnil); - break; - - case Bforward_line: - TOP = Fforward_line (TOP, Qnil); - 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 Bbuffer_substring: - v1 = POP; - TOP = Fbuffer_substring (TOP, v1, Qnil); - break; - - case Bdelete_region: - v1 = POP; - TOP = Fdelete_region (TOP, v1, Qnil); - break; - - case Bnarrow_to_region: - v1 = POP; - TOP = Fnarrow_to_region (TOP, v1, Qnil); - break; - - case Bwiden: - PUSH (Fwiden (Qnil)); - break; - - case Bend_of_line: - TOP = Fend_of_line (TOP, Qnil); - break; - - case Bset_marker: - v1 = POP; - v2 = POP; - TOP = Fset_marker (TOP, v2, v1); - break; - - case Bmatch_beginning: - TOP = Fmatch_beginning (TOP); - break; - - case Bmatch_end: - TOP = Fmatch_end (TOP); - break; - - case Bupcase: - TOP = Fupcase (TOP, Qnil); - break; - - case Bdowncase: - TOP = Fdowncase (TOP, Qnil); - break; - - case Bstringeqlsign: - v1 = POP; - TOP = Fstring_equal (TOP, v1); - break; - - case Bstringlss: - v1 = POP; - TOP = Fstring_lessp (TOP, v1); - break; - - case Bequal: - v1 = POP; - TOP = Fequal (TOP, v1); - break; - - case Bold_equal: - v1 = POP; - TOP = Fold_equal (TOP, v1); - break; - - case Bnthcdr: - v1 = POP; - v2 = TOP; - CHECK_NATNUM (v2); - for (op = XINT (v2); op; op--) - { - if (CONSP (v1)) - v1 = XCDR (v1); - else if (NILP (v1)) - break; - else - { - v1 = wrong_type_argument (Qlistp, v1); - op++; - } - } - 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) - { - /* Exchange args and then do nth. */ - v2 = POP; - v1 = TOP; - goto nth_entry; - } -#endif - v1 = POP; - TOP = Felt (TOP, v1); - break; - - case Bmember: - v1 = POP; - TOP = Fmember (TOP, v1); - break; - - case Bold_member: - v1 = POP; - TOP = Fold_member (TOP, v1); - break; + { + Lisp_Object arg = POP; + TOP = Fskip_chars_forward (TOP, arg, Qnil); + break; + } case Bassq: - v1 = POP; - TOP = Fassq (TOP, v1); - break; + { + Lisp_Object arg = POP; + TOP = Fassq (TOP, arg); + break; + } - case Bold_assq: - v1 = POP; - TOP = Fold_assq (TOP, v1); - break; + case Bsetcar: + { + Lisp_Object arg = POP; + TOP = Fsetcar (TOP, arg); + break; + } + + case Bsetcdr: + { + Lisp_Object arg = POP; + TOP = Fsetcdr (TOP, arg); + break; + } case Bnreverse: - TOP = Fnreverse (TOP); - break; - - case Bsetcar: - v1 = POP; - TOP = Fsetcar (TOP, v1); - break; - - case Bsetcdr: - v1 = POP; - TOP = Fsetcdr (TOP, v1); + TOP = bytecode_nreverse (TOP); break; case Bcar_safe: - v1 = TOP; - if (CONSP (v1)) - TOP = XCAR (v1); - else - TOP = Qnil; + TOP = CONSP (TOP) ? XCAR (TOP) : Qnil; break; case Bcdr_safe: - v1 = TOP; - if (CONSP (v1)) - TOP = XCDR (v1); - else - TOP = Qnil; + TOP = CONSP (TOP) ? XCDR (TOP) : Qnil; break; - case Bnconc: - DISCARD (1); - TOP = Fnconc (2, &TOP); + } + } +} + +/* 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 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: + { + Lisp_Object arg = POP; + TOP = internal_catch (TOP, Feval, arg, 0); + break; + } + + case Bskip_chars_backward: + { + Lisp_Object arg = POP; + TOP = Fskip_chars_backward (TOP, arg, Qnil); + break; + } + + case Bunwind_protect: + record_unwind_protect (Fprogn, POP); + break; + + case Bcondition_case: + { + Lisp_Object arg2 = POP; /* handlers */ + Lisp_Object arg1 = POP; /* bodyform */ + TOP = condition_case_3 (arg1, TOP, arg2); + break; + } + + case Bset_marker: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = POP; + TOP = Fset_marker (TOP, arg1, arg2); + break; + } + + case Brem: + { + Lisp_Object arg = POP; + TOP = Frem (TOP, arg); + break; + } + + case Bmatch_beginning: + TOP = Fmatch_beginning (TOP); + break; + + case Bmatch_end: + TOP = Fmatch_end (TOP); + break; + + case Bupcase: + TOP = Fupcase (TOP, Qnil); + break; + + case Bdowncase: + TOP = Fdowncase (TOP, Qnil); + break; + + case Bfset: + { + Lisp_Object arg = POP; + TOP = Ffset (TOP, arg); + break; + } + + case Bstring_equal: + { + Lisp_Object arg = POP; + TOP = Fstring_equal (TOP, arg); + break; + } + + case Bstring_lessp: + { + Lisp_Object arg = POP; + TOP = Fstring_lessp (TOP, arg); + break; + } + + case Bsubstring: + { + Lisp_Object arg2 = POP; + Lisp_Object arg1 = POP; + TOP = Fsubstring (TOP, arg1, arg2); + break; + } + + case Bcurrent_column: + PUSH (make_int (current_column (current_buffer))); + break; + + case Bchar_after: + TOP = Fchar_after (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 Bsave_current_buffer: + record_unwind_protect (save_current_buffer_restore, + Fcurrent_buffer ()); + break; + + case Binteractive_p: + PUSH (Finteractive_p ()); + break; + + case Bforward_char: + TOP = Fforward_char (TOP, Qnil); + break; + + case Bforward_word: + TOP = Fforward_word (TOP, Qnil); + break; + + case Bforward_line: + TOP = Fforward_line (TOP, Qnil); + break; + + case Bchar_syntax: + TOP = Fchar_syntax (TOP, Qnil); + break; + + case Bbuffer_substring: + { + Lisp_Object arg = POP; + TOP = Fbuffer_substring (TOP, arg, Qnil); + break; + } + + case Bdelete_region: + { + Lisp_Object arg = POP; + TOP = Fdelete_region (TOP, arg, Qnil); + break; + } + + case Bnarrow_to_region: + { + Lisp_Object arg = POP; + TOP = Fnarrow_to_region (TOP, arg, Qnil); + break; + } + + case Bend_of_line: + TOP = Fend_of_line (TOP, Qnil); + break; + + case Btemp_output_buffer_setup: + temp_output_buffer_setup (TOP); + TOP = Vstandard_output; + break; + + case Btemp_output_buffer_show: + { + Lisp_Object arg = POP; + temp_output_buffer_show (TOP, Qnil); + TOP = arg; + /* GAG ME!! */ + /* pop binding of standard-output */ + unbind_to (specpdl_depth() - 1, Qnil); + break; + } + + case Bold_eq: + { + Lisp_Object arg = POP; + TOP = HACKEQ_UNSAFE (TOP, arg) ? Qt : Qnil; + break; + } + + case Bold_memq: + { + Lisp_Object arg = POP; + TOP = Fold_memq (TOP, arg); + break; + } + + case Bold_equal: + { + Lisp_Object arg = POP; + TOP = Fold_equal (TOP, arg); + break; + } + + case Bold_member: + { + Lisp_Object arg = POP; + TOP = Fold_member (TOP, arg); + break; + } + + case Bold_assq: + { + Lisp_Object arg = POP; + TOP = Fold_assq (TOP, arg); + break; + } + + default: + abort(); + break; + } + return stack_ptr; +} + + +static void +invalid_byte_code_error (char *error_message, ...) +{ + Lisp_Object obj; + va_list args; + char *buf = alloca_array (char, strlen (error_message) + 128); + + sprintf (buf, "%s", error_message); + va_start (args, error_message); + obj = emacs_doprnt_string_va ((CONST Bufbyte *) GETTEXT (buf), Qnil, -1, + args); + va_end (args); + + signal_error (Qinvalid_byte_code, list1 (obj)); +} + +/* Check for valid opcodes. Change this when adding new opcodes. */ +static void +check_opcode (Opcode opcode) +{ + if ((opcode < Bvarref) || + (opcode == 0251) || + (opcode > Bassq && opcode < Bconstant)) + invalid_byte_code_error + ("invalid opcode %d in instruction stream", opcode); +} + +/* 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 Bnumberp: - TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; + 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 Bintegerp: - TOP = INTP (TOP) ? Qt : Qnil; + 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 Bconstant2: + READ_OPERAND_2; + WRITE_CONSTANT; + break; + + case BlistN: + case BconcatN: + case BinsertN: + READ_OPERAND_1; + WRITE_INT8 (arg, program_ptr); break; 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 + if (opcode < Bconstant) + check_opcode (opcode); + else + { + arg = opcode - Bconstant; + WRITE_CONSTANT; + } + break; } } - exit: + /* 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) + { + case Bgoto: + case Bgotoifnil: + case Bgotoifnonnil: + case Bgotoifnilelsepop: + case Bgotoifnonnilelsepop: + WRITE_INT16 (jump, p); + break; + + case BRgoto: + case BRgotoifnil: + case BRgotoifnonnil: + case BRgotoifnilelsepop: + case BRgotoifnonnilelsepop: + if (jump > SCHAR_MIN && + jump <= SCHAR_MAX) + { + WRITE_INT8 (jump, p); + } + else /* barf */ + { + struct jump *jj; + for (jj = jumps; jj < jumps_ptr; jj++) + { + assert (jj->from < program_ptr - program); + assert (jj->to < program_ptr - program); + if (jj->from > from) jj->from++; + if (jj->to > from) jj->to++; + } + p[-1] += Bgoto - BRgoto; + more_fixups_needed = 1; + memmove (p+1, p, program_ptr++ - p); + WRITE_INT16 (jump, p); + } + break; + + default: + abort(); + break; + } + } + } + } + + /* *program_ptr++ = 0; */ + *program_length = program_ptr - program; +} + +/* Optimize the byte code and store the optimized program, only + understood by bytecode.c, in an opaque object in the + instructions slot of the Compiled_Function object. */ +void +optimize_compiled_function (Lisp_Object compiled_function) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (compiled_function); + int program_length; + int varbind_count; + Opbyte *program; + + /* If we have not actually read the bytecode string + and constants vector yet, fetch them from the file. */ + if (CONSP (f->instructions)) + Ffetch_bytecode (compiled_function); + + if (STRINGP (f->instructions)) + { + /* XSTRING_LENGTH() is more efficient than XSTRING_CHAR_LENGTH(), + which would be slightly more `proper' */ + program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (f->instructions)); + optimize_byte_code (f->instructions, f->constants, + program, &program_length, &varbind_count); + f->specpdl_depth = XINT (Flength (f->arglist)) + varbind_count; + f->instructions = + Fpurecopy (make_opaque (program_length * sizeof (Opbyte), + (CONST void *) program)); + } + + assert (OPAQUEP (f->instructions)); +} + +/************************************************************************/ +/* The compiled-function object type */ +/************************************************************************/ +static void +print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, + int escapeflag) +{ + /* This function can GC */ + Lisp_Compiled_Function *f = + XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ + int docp = f->flags.documentationp; + int intp = f->flags.interactivep; + struct gcpro gcpro1, gcpro2; + char buf[100]; + GCPRO2 (obj, printcharfun); + + write_c_string (print_readably ? "#[" : "#", printcharfun); +} + + +static Lisp_Object +mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (obj); + + markobj (f->instructions); + markobj (f->arglist); + markobj (f->doc_and_interactive); +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + markobj (f->annotated); +#endif + /* tail-recurse on constants */ + return f->constants; +} + +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)); +} + +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)); +} + +DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, + mark_compiled_function, + print_compiled_function, 0, + compiled_function_equal, + compiled_function_hash, + Lisp_Compiled_Function); + +DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* +Return t if OBJECT is a byte-compiled function object. +*/ + (object)) +{ + return COMPILED_FUNCTIONP (object) ? Qt : Qnil; +} + +/************************************************************************/ +/* compiled-function object accessor functions */ +/************************************************************************/ + +Lisp_Object +compiled_function_arglist (Lisp_Compiled_Function *f) +{ + return f->arglist; } +Lisp_Object +compiled_function_instructions (Lisp_Compiled_Function *f) +{ + if (! OPAQUEP (f->instructions)) + return f->instructions; + + { + /* 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 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); + } +} + +Lisp_Object +compiled_function_constants (Lisp_Compiled_Function *f) +{ + return f->constants; +} + +int +compiled_function_stack_depth (Lisp_Compiled_Function *f) +{ + return f->stack_depth; +} + +/* 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 (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; +} + +#endif + +/* used only by Snarf-documentation; there must be doc already. */ +void +set_compiled_function_documentation (Lisp_Compiled_Function *f, + Lisp_Object new_doc) +{ + assert (f->flags.documentationp); + assert (INTP (new_doc) || STRINGP (new_doc)); + + if (f->flags.interactivep && f->flags.domainp) + XCAR (f->doc_and_interactive) = new_doc; + else if (f->flags.interactivep) + XCAR (f->doc_and_interactive) = new_doc; + else if (f->flags.domainp) + XCAR (f->doc_and_interactive) = new_doc; + else + f->doc_and_interactive = new_doc; +} + + +DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /* +Return the argument list of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_arglist (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /* +Return the byte-opcode string of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_instructions (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /* +Return the constants vector of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_constants (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /* +Return the max stack depth of the compiled-function object FUNCTION. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return make_int (compiled_function_stack_depth (XCOMPILED_FUNCTION (function))); +} + +DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /* +Return the doc string of the compiled-function object FUNCTION, if available. +Functions that had their doc strings snarfed into the DOC file will have +an integer returned instead of a string. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_documentation (XCOMPILED_FUNCTION (function)); +} + +DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /* +Return the interactive spec of the compiled-function object FUNCTION, or nil. +If non-nil, the return value will be a list whose first element is +`interactive' and whose second element is the interactive spec. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return XCOMPILED_FUNCTION (function)->flags.interactivep + ? list2 (Qinteractive, + compiled_function_interactive (XCOMPILED_FUNCTION (function))) + : Qnil; +} + +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + +/* Remove the `xx' if you wish to restore this feature */ +xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /* +Return the annotation of the compiled-function object FUNCTION, or nil. +The annotation is a piece of information indicating where this +compiled-function object came from. Generally this will be +a symbol naming a function; or a string naming a file, if the +compiled-function object was not defined in a function; or nil, +if the compiled-function object was not created as a result of +a `load'. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return compiled_function_annotation (XCOMPILED_FUNCTION (function)); +} + +#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ + +DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /* +Return the domain of the compiled-function object FUNCTION, or nil. +This is only meaningful if I18N3 was enabled when emacs was compiled. +*/ + (function)) +{ + CHECK_COMPILED_FUNCTION (function); + return XCOMPILED_FUNCTION (function)->flags.domainp + ? compiled_function_domain (XCOMPILED_FUNCTION (function)) + : Qnil; +} + + + +DEFUN ("fetch-bytecode", Ffetch_bytecode, 1, 1, 0, /* +If the byte code for compiled function FUNCTION is lazy-loaded, fetch it now. +*/ + (function)) +{ + Lisp_Compiled_Function *f; + CHECK_COMPILED_FUNCTION (function); + f = XCOMPILED_FUNCTION (function); + + if (OPAQUEP (f->instructions) || STRINGP (f->instructions)) + return function; + + if (CONSP (XCOMPILED_FUNCTION (function)->instructions)) + { + Lisp_Object tem = read_doc_string (f->instructions); + if (!CONSP (tem)) + signal_simple_error ("Invalid lazy-loaded byte code", tem); + /* v18 or v19 bytecode file. Need to Ebolify. */ + if (f->flags.ebolified && VECTORP (XCDR (tem))) + ebolify_bytecode_constants (XCDR (tem)); + /* VERY IMPORTANT to purecopy here!!!!! + See load_force_doc_string_unwind. */ + /* f->instructions = Fpurecopy (XCAR (tem)); */ + f->constants = Fpurecopy (XCDR (tem)); + return function; + } + abort (); + return Qnil; /* not reached */ +} + +DEFUN ("optimize-compiled-function", Foptimize_compiled_function, 1, 1, 0, /* +Convert compiled function FUNCTION into an optimized internal form. +*/ + (function)) +{ + Lisp_Compiled_Function *f; + CHECK_COMPILED_FUNCTION (function); + f = XCOMPILED_FUNCTION (function); + + if (OPAQUEP (f->instructions)) /* Already optimized? */ + return Qnil; + + optimize_compiled_function (function); + return Qnil; +} + +DEFUN ("byte-code", Fbyte_code, 3, 3, 0, /* +Function used internally in byte-compiled code. +First argument INSTRUCTIONS is a string of byte code. +Second argument CONSTANTS is a vector of constants. +Third argument STACK-DEPTH is the maximum stack depth used in this function. +If STACK-DEPTH is incorrect, Emacs may crash. +*/ + (instructions, constants, stack_depth)) +{ + /* This function can GC */ + int varbind_count; + int program_length; + Opbyte *program; + + CHECK_STRING (instructions); + CHECK_VECTOR (constants); + CHECK_NATNUM (stack_depth); + + /* Optimize the `instructions' string, just like when executing a + regular compiled function, but don't save it for later since this is + likely to only be executed once. */ + program = alloca_array (Opbyte, 1 + 2 * XSTRING_LENGTH (instructions)); + optimize_byte_code (instructions, constants, program, + &program_length, &varbind_count); + SPECPDL_RESERVE (varbind_count); + return execute_optimized_program (program, + XINT (stack_depth), + XVECTOR_DATA (constants)); +} + + void syms_of_bytecode (void) { + deferror (&Qinvalid_byte_code, "invalid-byte-code", + "Invalid byte code", Qerror); defsymbol (&Qbyte_code, "byte-code"); + defsymbol (&Qcompiled_functionp, "compiled-function-p"); + DEFSUBR (Fbyte_code); + DEFSUBR (Ffetch_bytecode); + DEFSUBR (Foptimize_compiled_function); + + DEFSUBR (Fcompiled_function_p); + DEFSUBR (Fcompiled_function_instructions); + DEFSUBR (Fcompiled_function_constants); + DEFSUBR (Fcompiled_function_stack_depth); + DEFSUBR (Fcompiled_function_arglist); + DEFSUBR (Fcompiled_function_interactive); + DEFSUBR (Fcompiled_function_doc_string); + DEFSUBR (Fcompiled_function_domain); +#ifdef COMPILED_FUNCTION_ANNOTATION_HACK + DEFSUBR (Fcompiled_function_annotation); +#endif + #ifdef BYTE_CODE_METER defsymbol (&Qbyte_code_meter, "byte-code-meter"); #endif @@ -1197,7 +2436,7 @@ #ifdef BYTE_CODE_METER DEFVAR_LISP ("byte-code-meter", &Vbyte_code_meter /* -A vector of vectors which holds a histogram of byte-code usage. +A vector of vectors which holds a histogram of byte code usage. \(aref (aref byte-code-meter 0) CODE) indicates how many times the byte opcode CODE has been executed. \(aref (aref byte-code-meter CODE1) CODE2), where CODE1 is not 0, @@ -1206,7 +2445,7 @@ */ ); DEFVAR_BOOL ("byte-metering-on", &byte_metering_on /* If non-nil, keep profiling information on byte code usage. -The variable byte-code-meter indicates how often each byte opcode is used. +The variable `byte-code-meter' indicates how often each byte opcode is used. If a symbol has a property named `byte-code-meter' whose value is an integer, it is incremented each time that symbol's function is called. */ ); @@ -1216,8 +2455,7 @@ { int i = 256; while (i--) - XVECTOR_DATA (Vbyte_code_meter)[i] = - make_vector (256, Qzero); + XVECTOR_DATA (Vbyte_code_meter)[i] = make_vector (256, Qzero); } -#endif +#endif /* BYTE_CODE_METER */ } diff -r 76b7d63099ad -r 8626e4521993 src/bytecode.h --- a/src/bytecode.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/bytecode.h Mon Aug 13 11:07:10 2007 +0200 @@ -30,14 +30,15 @@ #ifndef _XEMACS_BYTECODE_H_ #define _XEMACS_BYTECODE_H_ -/* Meanings of slots in a Lisp_Compiled_Function. */ -#define COMPILED_ARGLIST 0 -#define COMPILED_BYTECODE 1 -#define COMPILED_CONSTANTS 2 -#define COMPILED_STACK_DEPTH 3 -#define COMPILED_DOC_STRING 4 -#define COMPILED_INTERACTIVE 5 -#define COMPILED_DOMAIN 6 +/* Meanings of slots in a Lisp_Compiled_Function. + Don't use these! For backward compatibility only. */ +#define COMPILED_ARGLIST 0 +#define COMPILED_INSTRUCTIONS 1 +#define COMPILED_CONSTANTS 2 +#define COMPILED_STACK_DEPTH 3 +#define COMPILED_DOC_STRING 4 +#define COMPILED_INTERACTIVE 5 +#define COMPILED_DOMAIN 6 /* It doesn't make sense to have this and also have load-history */ /* #define COMPILED_FUNCTION_ANNOTATION_HACK */ @@ -45,7 +46,8 @@ struct Lisp_Compiled_Function { struct lrecord_header lheader; - unsigned short maxdepth; + unsigned short stack_depth; + unsigned short specpdl_depth; struct { unsigned int documentationp: 1; @@ -56,7 +58,7 @@ We need to Ebolify the `assoc', `delq', etc. functions. */ unsigned int ebolified: 1; } flags; - Lisp_Object bytecodes; + Lisp_Object instructions; Lisp_Object constants; Lisp_Object arglist; /* This uses the minimal number of conses; see accessors in data.c. */ @@ -66,25 +68,35 @@ 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, ...); + +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); -DECLARE_LRECORD (compiled_function, struct Lisp_Compiled_Function); +void set_compiled_function_documentation (Lisp_Compiled_Function *f, + Lisp_Object new_doc); + +Lisp_Object funcall_compiled_function (Lisp_Object fun, + int nargs, Lisp_Object args[]); +void optimize_compiled_function (Lisp_Object compiled_function); + +DECLARE_LRECORD (compiled_function, Lisp_Compiled_Function); #define XCOMPILED_FUNCTION(x) XRECORD (x, compiled_function, \ - struct Lisp_Compiled_Function) + Lisp_Compiled_Function) #define XSETCOMPILED_FUNCTION(x, p) XSETRECORD (x, p, compiled_function) #define COMPILED_FUNCTIONP(x) RECORDP (x, compiled_function) #define GC_COMPILED_FUNCTIONP(x) GC_RECORDP (x, compiled_function) #define CHECK_COMPILED_FUNCTION(x) CHECK_RECORD (x, compiled_function) #define CONCHECK_COMPILED_FUNCTION(x) CONCHECK_RECORD (x, compiled_function) -EXFUN (Fbyte_code, 3); - extern Lisp_Object Qbyte_code; /* total 1765 internal 101 doc-and-int 775 doc-only 389 int-only 42 neither 559 diff -r 76b7d63099ad -r 8626e4521993 src/callint.c --- a/src/callint.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/callint.c Mon Aug 13 11:07:10 2007 +0200 @@ -294,10 +294,10 @@ } else if (COMPILED_FUNCTIONP (fun)) { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - if (!(b->flags.interactivep)) + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + if (! f->flags.interactivep) goto lose; - specs = compiled_function_interactive (b); + specs = compiled_function_interactive (f); } else if (!CONSP (fun)) goto lose; @@ -405,7 +405,7 @@ { Lisp_Object domain = Qnil; if (COMPILED_FUNCTIONP (fun)) - domain = Fcompiled_function_domain (fun); + domain = compiled_function_domain (XCOMPILED_FUNCTION (fun)); if (NILP (domain)) specs = Fgettext (specs); else @@ -525,7 +525,7 @@ struct gcpro gcpro1; GCPRO1 (fun); - fun = funcall_recording_as (function, 1, &fun); + fun = Ffuncall (1, &fun); UNGCPRO; } if (set_zmacs_region_stays) diff -r 76b7d63099ad -r 8626e4521993 src/callproc.c --- a/src/callproc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/callproc.c Mon Aug 13 11:07:10 2007 +0200 @@ -28,7 +28,6 @@ #include "commands.h" #include "insdel.h" #include "lstream.h" -#include #include "process.h" #include "sysdep.h" #include "window.h" @@ -314,19 +313,11 @@ { /* child_setup must clobber environ in systems with true vfork. - Protect it from permanent change. */ - REGISTER char **save_environ = environ; - REGISTER int fd1 = fd[1]; - int fd_error = fd1; - char **env; - -#ifdef EMACS_BTL - /* when performance monitoring is on, turn it off before the vfork(), - as the child has no handler for the signal -- when back in the - parent process, turn it back on if it was really on when you "turned - it off" */ - int logging_on = cadillac_stop_logging (); -#endif /* EMACS_BTL */ + Protect it from permanent change. */ + REGISTER char **save_environ = environ; + REGISTER int fd1 = fd[1]; + int fd_error = fd1; + char **env; env = environ; @@ -385,10 +376,6 @@ child_setup (filefd, fd1, fd_error, new_argv, (char *) XSTRING_DATA (current_dir)); } -#ifdef EMACS_BTL - else if (logging_on) - cadillac_start_logging (); -#endif if (fd_error >= 0) close (fd_error); @@ -534,9 +521,30 @@ +/* Move the file descriptor FD so that its number is not less than MIN. * + The original file descriptor remains open. */ +static int +relocate_fd (int fd, int min) +{ + if (fd >= min) + return fd; + else + { + int newfd = dup (fd); + if (newfd == -1) + { + stderr_out ("Error while setting up child: %s\n", + strerror (errno)); + _exit (1); + } + return relocate_fd (newfd, min); + } +} + /* This is the last thing run in a newly forked inferior either synchronous or asynchronous. - Copy descriptors IN, OUT and ERR as descriptors 0, 1 and 2. + Copy descriptors IN, OUT and ERR + as descriptors STDIN_FILENO, STDOUT_FILENO, and STDERR_FILENO. Initialize inferior's priority, pgrp, connected dir and environment. then exec another program based on new_argv. @@ -554,8 +562,6 @@ a decent error from within the child, this should be verified as an executable directory by the parent. */ -static int relocate_fd (int fd, int min); - #ifdef WINDOWSNT int #else @@ -685,29 +691,19 @@ 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); + in = relocate_fd (in, 3); + out = relocate_fd (out, 3); + err = relocate_fd (err, 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); - + /* Set the standard input/output channels of the new process. */ + close (STDIN_FILENO); + close (STDOUT_FILENO); + close (STDERR_FILENO); + + dup2 (in, STDIN_FILENO); + dup2 (out, STDOUT_FILENO); + dup2 (err, STDERR_FILENO); + close (in); close (out); close (err); @@ -719,9 +715,7 @@ { int fd; for (fd=3; fd<=64; fd++) - { - close(fd); - } + close (fd); } #endif /* not WINDOWSNT */ @@ -749,30 +743,6 @@ #endif /* not WINDOWSNT */ } -/* Move the file descriptor FD so that its number is not less than MIN. - If the file descriptor is moved at all, the original is freed. */ -static int -relocate_fd (int fd, int min) -{ - if (fd >= min) - return fd; - else - { - int new = dup (fd); - if (new == -1) - { - stderr_out ("Error while setting up child: %s\n", - strerror (errno)); - _exit (1); - } - /* Note that we hold the original FD open while we recurse, - to guarantee we'll get a new FD if we need it. */ - new = relocate_fd (new, min); - close (fd); - return new; - } -} - static int getenv_internal (CONST Bufbyte *var, Bytecount varlen, diff -r 76b7d63099ad -r 8626e4521993 src/casefiddle.c --- a/src/casefiddle.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/casefiddle.c Mon Aug 13 11:07:10 2007 +0200 @@ -289,39 +289,39 @@ } DEFUN ("upcase-word", Fupcase_word, 1, 2, "p", /* -Convert following word (or ARG words) to upper case, moving over. +Convert following word (or N words) to upper case, moving over. With negative argument, convert previous words but do not move. See also `capitalize-word'. Optional second arg BUFFER defaults to the current buffer. */ - (arg, buffer)) + (n, buffer)) { /* This function can GC */ - return casify_word (CASE_UP, arg, buffer); + return casify_word (CASE_UP, n, buffer); } DEFUN ("downcase-word", Fdowncase_word, 1, 2, "p", /* -Convert following word (or ARG words) to lower case, moving over. +Convert following word (or N words) to lower case, moving over. With negative argument, convert previous words but do not move. Optional second arg BUFFER defaults to the current buffer. */ - (arg, buffer)) + (n, buffer)) { /* This function can GC */ - return casify_word (CASE_DOWN, arg, buffer); + return casify_word (CASE_DOWN, n, buffer); } DEFUN ("capitalize-word", Fcapitalize_word, 1, 2, "p", /* -Capitalize the following word (or ARG words), moving over. +Capitalize the following word (or N words), moving over. This gives the word(s) a first character in upper case and the rest lower case. With negative argument, capitalize previous words but do not move. Optional second arg BUFFER defaults to the current buffer. */ - (arg, buffer)) + (n, buffer)) { /* This function can GC */ - return casify_word (CASE_CAPITALIZE, arg, buffer); + return casify_word (CASE_CAPITALIZE, n, buffer); } diff -r 76b7d63099ad -r 8626e4521993 src/chartab.c --- a/src/chartab.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/chartab.c Mon Aug 13 11:07:10 2007 +0200 @@ -38,7 +38,6 @@ #include "buffer.h" #include "chartab.h" -#include "commands.h" #include "syntax.h" Lisp_Object Qchar_tablep, Qchar_table; @@ -98,7 +97,7 @@ for (i = 0; i < 96; i++) { - (markobj) (cte->level2[i]); + markobj (cte->level2[i]); } return Qnil; } @@ -139,17 +138,17 @@ int i; for (i = 0; i < NUM_ASCII_CHARS; i++) - (markobj) (ct->ascii[i]); + markobj (ct->ascii[i]); #ifdef MULE for (i = 0; i < NUM_LEADING_BYTES; i++) - (markobj) (ct->level1[i]); + markobj (ct->level1[i]); #endif return ct->mirror_table; } /* WARNING: All functions of this nature need to be written extremely carefully to avoid crashes during GC. Cf. prune_specifiers() - and prune_weak_hashtables(). */ + and prune_weak_hash_tables(). */ void prune_syntax_tables (int (*obj_marked_p) (Lisp_Object)) @@ -160,7 +159,7 @@ !GC_NILP (rest); rest = XCHAR_TABLE (rest)->next_table) { - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (rest)) { /* This table is garbage. Remove it from the list. */ if (GC_NILP (prev)) @@ -177,6 +176,7 @@ { switch (type) { + default: abort(); case CHAR_TABLE_TYPE_GENERIC: return Qgeneric; case CHAR_TABLE_TYPE_SYNTAX: return Qsyntax; case CHAR_TABLE_TYPE_DISPLAY: return Qdisplay; @@ -185,9 +185,6 @@ case CHAR_TABLE_TYPE_CATEGORY: return Qcategory; #endif } - - abort (); - return Qnil; /* not reached */ } static enum char_table_type diff -r 76b7d63099ad -r 8626e4521993 src/chpdef.h --- a/src/chpdef.h Mon Aug 13 11:06:08 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -/* 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: FSF 19.30. */ - -#define CHP$_END 0 -#define CHP$_ACCESS 1 -#define CHP$_FLAGS 2 -#define CHP$_PRIV 3 -#define CHP$_ACMODE 4 -#define CHP$_ACCLASS 5 -#define CHP$_RIGHTS 6 -#define CHP$_ADDRIGHTS 7 -#define CHP$_MODE 8 -#define CHP$_MODES 9 -#define CHP$_MINCLASS 10 -#define CHP$_MAXCLASS 11 -#define CHP$_OWNER 12 -#define CHP$_PROT 13 -#define CHP$_ACL 14 -#define CHP$_AUDITNAME 15 -#define CHP$_ALARMNAME 16 -#define CHP$_MATCHEDACE 17 -#define CHP$_PRIVUSED 18 -#define CHP$_MAX_CODE 19 -#define CHP$M_SYSPRV 1 -#define CHP$M_BYPASS 2 -#define CHP$M_UPGRADE 4 -#define CHP$M_DOWNGRADE 8 -#define CHP$M_GRPPRV 16 -#define CHP$M_READALL 32 -#define CHP$V_SYSPRV 0 -#define CHP$V_BYPASS 1 -#define CHP$V_UPGRADE 2 -#define CHP$V_DOWNGRADE 3 -#define CHP$V_GRPPRV 4 -#define CHP$V_READALL 5 -#define CHP$M_READ 1 -#define CHP$M_WRITE 2 -#define CHP$M_USEREADALL 4 -#define CHP$V_READ 0 -#define CHP$V_WRITE 1 -#define CHP$V_USEREADALL 2 diff -r 76b7d63099ad -r 8626e4521993 src/cmdloop.c --- a/src/cmdloop.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/cmdloop.c Mon Aug 13 11:07:10 2007 +0200 @@ -35,7 +35,6 @@ #include "commands.h" #include "frame.h" #include "events.h" -#include "macros.h" #include "window.h" /* Current depth in recursive edits. */ diff -r 76b7d63099ad -r 8626e4521993 src/cmds.c --- a/src/cmds.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/cmds.c Mon Aug 13 11:07:10 2007 +0200 @@ -43,27 +43,31 @@ Lisp_Object Vself_insert_face_command; DEFUN ("forward-char", Fforward_char, 0, 2, "_p", /* -Move point right ARG characters (left if ARG negative). +Move point right N characters (left if N negative). On attempt to pass end of buffer, stop and signal `end-of-buffer'. On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'. On reaching end of buffer, stop and signal error. */ - (arg, buffer)) + (n, buffer)) { struct buffer *buf = decode_buffer (buffer, 1); + EMACS_INT count; - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + count = 1; else - CHECK_INT (arg); + { + CHECK_INT (n); + count = XINT (n); + } - /* This used to just set point to point + XINT (arg), and then check + /* This used to just set point to point + XINT (n), and then check to see if it was within boundaries. But now that SET_PT can potentially do a lot of stuff (calling entering and exiting hooks, etcetera), that's not a good approach. So we validate the proposed position, then set point. */ { - Bufpos new_point = BUF_PT (buf) + XINT (arg); + Bufpos new_point = BUF_PT (buf) + count; if (new_point < BUF_BEGV (buf)) { @@ -85,44 +89,45 @@ } DEFUN ("backward-char", Fbackward_char, 0, 2, "_p", /* -Move point left ARG characters (right if ARG negative). +Move point left N characters (right if N negative). On attempt to pass end of buffer, stop and signal `end-of-buffer'. On attempt to pass beginning of buffer, stop and signal `beginning-of-buffer'. */ - (arg, buffer)) + (n, buffer)) { - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + n = make_int (-1); else - CHECK_INT (arg); - - XSETINT (arg, - XINT (arg)); - return Fforward_char (arg, buffer); + { + CHECK_INT (n); + XSETINT (n, - XINT (n)); + } + return Fforward_char (n, buffer); } DEFUN ("forward-line", Fforward_line, 0, 2, "_p", /* -Move ARG lines forward (backward if ARG is negative). -Precisely, if point is on line I, move to the start of line I + ARG. +Move N lines forward (backward if N is negative). +Precisely, if point is on line I, move to the start of line I + N. If there isn't room, go as far as possible (no error). Returns the count of lines left to move. If moving forward, -that is ARG - number of lines moved; if backward, ARG + number moved. -With positive ARG, a non-empty line at the end counts as one line +that is N - number of lines moved; if backward, N + number moved. +With positive N, a non-empty line at the end counts as one line successfully moved (for the return value). If BUFFER is nil, the current buffer is assumed. */ - (arg, buffer)) + (n, buffer)) { struct buffer *buf = decode_buffer (buffer, 1); Bufpos pos2 = BUF_PT (buf); Bufpos pos; EMACS_INT count, shortage, negp; - if (NILP (arg)) + if (NILP (n)) count = 1; else { - CHECK_INT (arg); - count = XINT (arg); + CHECK_INT (n); + count = XINT (n); } negp = count <= 0; @@ -143,36 +148,39 @@ If scan reaches end of buffer, return that position. This function does not move point. */ - (arg, buffer)) + (n, buffer)) { struct buffer *b = decode_buffer (buffer, 1); REGISTER int orig, end; XSETBUFFER (buffer, b); - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + n = make_int (0); else - CHECK_INT (arg); + { + CHECK_INT (n); + n = make_int (XINT (n) - 1); + } - orig = BUF_PT(b); - Fforward_line (make_int (XINT (arg) - 1), buffer); - end = BUF_PT(b); - BUF_SET_PT(b, orig); + orig = BUF_PT (b); + Fforward_line (n, buffer); + end = BUF_PT (b); + BUF_SET_PT (b, orig); return make_int (end); } DEFUN ("beginning-of-line", Fbeginning_of_line, 0, 2, "_p", /* Move point to beginning of current line. -With argument ARG not nil or 1, move forward ARG - 1 lines first. +With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, stop there without error. If BUFFER is nil, the current buffer is assumed. */ - (arg, buffer)) + (n, buffer)) { struct buffer *b = decode_buffer (buffer, 1); - BUF_SET_PT(b, XINT (Fpoint_at_bol(arg, buffer))); + BUF_SET_PT (b, XINT (Fpoint_at_bol (n, buffer))); return Qnil; } @@ -182,53 +190,57 @@ 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); - - XSETBUFFER (buffer, buf); + int count; - if (NILP (arg)) - arg = make_int (1); + if (NILP (n)) + count = 1; else - CHECK_INT (arg); + { + CHECK_INT (n); + count = XINT (n); + } return make_int (find_before_next_newline (buf, BUF_PT (buf), 0, - XINT (arg) - (XINT (arg) <= 0))); + count - (count <= 0))); } DEFUN ("end-of-line", Fend_of_line, 0, 2, "_p", /* Move point to end of current line. -With argument ARG not nil or 1, move forward ARG - 1 lines first. +With argument N not nil or 1, move forward N - 1 lines first. If scan reaches end of buffer, stop there without error. If BUFFER is nil, the current buffer is assumed. */ - (arg, buffer)) + (n, buffer)) { struct buffer *b = decode_buffer (buffer, 1); - BUF_SET_PT(b, XINT (Fpoint_at_eol (arg, buffer))); + BUF_SET_PT (b, XINT (Fpoint_at_eol (n, buffer))); return Qnil; } DEFUN ("delete-char", Fdelete_char, 1, 2, "*p\nP", /* -Delete the following ARG characters (previous, with negative arg). +Delete the following N characters (previous, with negative N). Optional second arg KILLFLAG non-nil means kill instead (save in kill ring). -Interactively, ARG is the prefix arg, and KILLFLAG is set if -ARG was explicitly specified. +Interactively, N is the prefix arg, and KILLFLAG is set if +N was explicitly specified. */ - (arg, killflag)) + (n, killflag)) { /* This function can GC */ Bufpos pos; struct buffer *buf = current_buffer; + int count; - CHECK_INT (arg); + CHECK_INT (n); + count = XINT (n); - pos = BUF_PT (buf) + XINT (arg); + pos = BUF_PT (buf) + count; if (NILP (killflag)) { - if (XINT (arg) < 0) + if (count < 0) { if (pos < BUF_BEGV (buf)) signal_error (Qbeginning_of_buffer, Qnil); @@ -245,22 +257,22 @@ } else { - call1 (Qkill_forward_chars, arg); + call1 (Qkill_forward_chars, n); } return Qnil; } DEFUN ("delete-backward-char", Fdelete_backward_char, 1, 2, "*p\nP", /* -Delete the previous ARG characters (following, with negative ARG). +Delete the previous N characters (following, with negative N). Optional second arg KILLFLAG non-nil means kill instead (save in kill ring). -Interactively, ARG is the prefix arg, and KILLFLAG is set if -ARG was explicitly specified. +Interactively, N is the prefix arg, and KILLFLAG is set if +N was explicitly specified. */ - (arg, killflag)) + (n, killflag)) { /* This function can GC */ - CHECK_INT (arg); - return Fdelete_char (make_int (-XINT (arg)), killflag); + CHECK_INT (n); + return Fdelete_char (make_int (- XINT (n)), killflag); } static void internal_self_insert (Emchar ch, int noautofill); @@ -269,13 +281,15 @@ Insert the character you type. Whichever character you type to run this command is inserted. */ - (arg)) + (n)) { /* This function can GC */ - int n; Emchar ch; Lisp_Object c; - CHECK_INT (arg); + int count; + + CHECK_NATNUM (n); + count = XINT (n); if (CHAR_OR_CHAR_INTP (Vlast_command_char)) c = Vlast_command_char; @@ -283,36 +297,16 @@ c = Fevent_to_character (Vlast_command_event, Qnil, Qnil, Qt); if (NILP (c)) - signal_simple_error ("last typed character has no ASCII equivalent", + signal_simple_error ("Last typed character has no ASCII equivalent", Fcopy_event (Vlast_command_event, Qnil)); CHECK_CHAR_COERCE_INT (c); - n = XINT (arg); ch = XCHAR (c); -#if 0 /* FSFmacs */ - /* #### This optimization won't work because of differences in - how the start-open and end-open properties default for text - properties. See internal_self_insert(). */ - if (n >= 2 && NILP (current_buffer->overwrite_mode)) - { - n -= 2; - /* The first one might want to expand an abbrev. */ - internal_self_insert (c, 1); - /* The bulk of the copies of this char can be inserted simply. - We don't have to handle a user-specified face specially - because it will get inherited from the first char inserted. */ - Finsert_char (make_char (c), make_int (n), Qt, Qnil); - /* The last one might want to auto-fill. */ - internal_self_insert (c, 0); - } - else -#endif /* 0 */ - while (n > 0) - { - n--; - internal_self_insert (ch, (n != 0)); - } + + while (count--) + internal_self_insert (ch, (count != 0)); + return Qnil; } @@ -335,6 +329,7 @@ Lisp_Object overwrite; struct Lisp_Char_Table *syntax_table; struct buffer *buf = current_buffer; + int tab_width; overwrite = buf->overwrite_mode; syntax_table = XCHAR_TABLE (buf->mirror_syntax_table); @@ -354,9 +349,9 @@ || (c1 != '\n' && BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\n')) && (EQ (overwrite, Qoverwrite_mode_binary) || BUF_FETCH_CHAR (buf, BUF_PT (buf)) != '\t' - || XINT (buf->tab_width) <= 0 - || XINT (buf->tab_width) > 20 - || !((current_column (buf) + 1) % XINT (buf->tab_width)))) + || ((tab_width = XINT (buf->tab_width), tab_width <= 0) + || tab_width > 20 + || !((current_column (buf) + 1) % tab_width)))) { buffer_delete_range (buf, BUF_PT (buf), BUF_PT (buf) + 1, 0); /* hairy = 2; */ diff -r 76b7d63099ad -r 8626e4521993 src/config.h.in --- a/src/config.h.in Mon Aug 13 11:06:08 2007 +0200 +++ b/src/config.h.in Mon Aug 13 11:07:10 2007 +0200 @@ -403,11 +403,19 @@ determine where XEmacs' memory is going. */ #undef MEMORY_USAGE_STATS -/* Define QUANTIFY if using Quantify from Pure/Atria Software. +/* Define QUANTIFY if using Quantify from Rational/Pure/Atria Software. This adds some additional calls to control data collection. It is only intended for use by the developers. */ #undef QUANTIFY +/* Define QUANTIFY if using Purify from Rational/Pure/Atria Software. + It is only intended for use by the developers. */ +#undef PURIFY + +#if (defined (QUANTIFY) || defined (PURIFY)) && !defined (XLIB_ILLEGAL_ACCESS) +#define XLIB_ILLEGAL_ACCESS 1 +#endif + /* Define EXTERNAL_WIDGET to compile support for using the editor as a widget within another program. */ #undef EXTERNAL_WIDGET diff -r 76b7d63099ad -r 8626e4521993 src/conslots.h --- a/src/conslots.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/conslots.h Mon Aug 13 11:07:10 2007 +0200 @@ -46,7 +46,7 @@ /* Most-recently-selected non-minibuffer-only frame. Always the same as the selected frame, unless that's a minibuffer-only frame. */ - MARKED_SLOT (_last_nonminibuf_frame); + MARKED_SLOT (last_nonminibuf_frame); /* If non-nil, a keymap that overrides all others but applies only to this console. Lisp code that uses this instead of calling next-event diff -r 76b7d63099ad -r 8626e4521993 src/console-msw.h --- a/src/console-msw.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console-msw.h Mon Aug 13 11:07:10 2007 +0200 @@ -133,7 +133,7 @@ /* DC for this win32 window */ HDC hdc; - /* compatibke DC for bitmap operations */ + /* compatible DC for bitmap operations */ HDC cdc; /* Time of last click event, for button 2 emul */ @@ -142,13 +142,13 @@ /* Coordinates of last click event, screen-relative */ POINTS last_click_point; #ifdef HAVE_TOOLBARS - /* Toolbar hashtable. See toolbar-msw.c */ - Lisp_Object toolbar_hashtable; + /* Toolbar hash table. See toolbar-msw.c */ + Lisp_Object toolbar_hash_table; unsigned int toolbar_checksum[4]; #endif - /* Menu hashtable. See menubar-msw.c */ - Lisp_Object menu_hashtable; + /* Menu hash table. See menubar-msw.c */ + Lisp_Object menu_hash_table; /* Menu checksum. See menubar-msw.c */ unsigned int menu_checksum; @@ -175,12 +175,12 @@ #define FRAME_MSWINDOWS_DATA(f) FRAME_TYPE_DATA (f, mswindows) -#define FRAME_MSWINDOWS_HANDLE(f) (FRAME_MSWINDOWS_DATA (f)->hwnd) -#define FRAME_MSWINDOWS_DC(f) (FRAME_MSWINDOWS_DATA (f)->hdc) -#define FRAME_MSWINDOWS_CDC(f) (FRAME_MSWINDOWS_DATA (f)->cdc) -#define FRAME_MSWINDOWS_MENU_HASHTABLE(f) (FRAME_MSWINDOWS_DATA (f)->menu_hashtable) -#define FRAME_MSWINDOWS_TOOLBAR_HASHTABLE(f) \ - (FRAME_MSWINDOWS_DATA (f)->toolbar_hashtable) +#define FRAME_MSWINDOWS_HANDLE(f) (FRAME_MSWINDOWS_DATA (f)->hwnd) +#define FRAME_MSWINDOWS_DC(f) (FRAME_MSWINDOWS_DATA (f)->hdc) +#define FRAME_MSWINDOWS_CDC(f) (FRAME_MSWINDOWS_DATA (f)->cdc) +#define FRAME_MSWINDOWS_MENU_HASH_TABLE(f) (FRAME_MSWINDOWS_DATA (f)->menu_hash_table) +#define FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f) \ + (FRAME_MSWINDOWS_DATA (f)->toolbar_hash_table) #define FRAME_MSWINDOWS_TOOLBAR_CHECKSUM(f,pos) \ (FRAME_MSWINDOWS_DATA (f)->toolbar_checksum[pos]) #define FRAME_MSWINDOWS_MENU_CHECKSUM(f) (FRAME_MSWINDOWS_DATA (f)->menu_checksum) diff -r 76b7d63099ad -r 8626e4521993 src/console-tty.c --- a/src/console-tty.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console-tty.c Mon Aug 13 11:07:10 2007 +0200 @@ -32,7 +32,6 @@ #include "faces.h" #include "frame.h" #include "lstream.h" -#include "redisplay.h" #include "sysdep.h" #include "sysfile.h" #ifdef FILE_CODING @@ -165,9 +164,9 @@ tty_mark_console (struct console *con, void (*markobj) (Lisp_Object)) { struct tty_console *tty_con = CONSOLE_TTY_DATA (con); - ((markobj) (tty_con->terminal_type)); - ((markobj) (tty_con->instream)); - ((markobj) (tty_con->outstream)); + markobj (tty_con->terminal_type); + markobj (tty_con->instream); + markobj (tty_con->outstream); } static int diff -r 76b7d63099ad -r 8626e4521993 src/console-tty.h --- a/src/console-tty.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console-tty.h Mon Aug 13 11:07:10 2007 +0200 @@ -220,21 +220,17 @@ #define TTY_FLAGS(c) (CONSOLE_TTY_DATA (c)->flags) #define TTY_COST(c) (CONSOLE_TTY_DATA (c)->cost) -#define TTY_INC_CURSOR_X(c, n) \ -do \ -{ \ - int __tempn__ = (n); \ +#define TTY_INC_CURSOR_X(c, n) do { \ + int TICX_n = (n); \ assert (CONSOLE_TTY_CURSOR_X (c) == CONSOLE_TTY_REAL_CURSOR_X (c)); \ - CONSOLE_TTY_CURSOR_X (c) += __tempn__; \ - CONSOLE_TTY_REAL_CURSOR_X (c) += __tempn__; \ + CONSOLE_TTY_CURSOR_X (c) += TICX_n; \ + CONSOLE_TTY_REAL_CURSOR_X (c) += TICX_n; \ } while (0) -#define TTY_INC_CURSOR_Y(c, n) \ -do \ -{ \ - int __tempn__ = (n); \ - CONSOLE_TTY_CURSOR_Y (c) += __tempn__; \ - CONSOLE_TTY_REAL_CURSOR_Y (c) += __tempn__; \ +#define TTY_INC_CURSOR_Y(c, n) do { \ + int TICY_n = (n); \ + CONSOLE_TTY_CURSOR_Y (c) += TICY_n; \ + CONSOLE_TTY_REAL_CURSOR_Y (c) += TICY_n; \ } while (0) struct tty_device diff -r 76b7d63099ad -r 8626e4521993 src/console-x.c --- a/src/console-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -104,7 +104,7 @@ { CONST char *disp_name; - /* If the user didn't explicitly specifify a display to use when + /* If the user didn't explicitly specify a display to use when they called make-x-device, then we first check to see if a display was specified on the command line with -display. If so, we set disp_name to it. Otherwise we use XDisplayName to diff -r 76b7d63099ad -r 8626e4521993 src/console-x.h --- a/src/console-x.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console-x.h Mon Aug 13 11:07:10 2007 +0200 @@ -134,7 +134,7 @@ int x_keysym_map_min_code; int x_keysym_map_max_code; int x_keysym_map_keysyms_per_code; - Lisp_Object x_keysym_map_hashtable; + Lisp_Object x_keysym_map_hash_table; /* frame that holds the WM_COMMAND property; there should be exactly one of these per device. */ @@ -198,7 +198,7 @@ #define DEVICE_X_MOUSE_TIMESTAMP(d) (DEVICE_X_DATA (d)->mouse_timestamp) #define DEVICE_X_GLOBAL_MOUSE_TIMESTAMP(d) (DEVICE_X_DATA (d)->global_mouse_timestamp) #define DEVICE_X_LAST_SERVER_TIMESTAMP(d) (DEVICE_X_DATA (d)->last_server_timestamp) -#define DEVICE_X_KEYSYM_MAP_HASHTABLE(d) (DEVICE_X_DATA (d)->x_keysym_map_hashtable) +#define DEVICE_X_KEYSYM_MAP_HASH_TABLE(d) (DEVICE_X_DATA (d)->x_keysym_map_hash_table) /* #define DEVICE_X_X_COMPOSE_STATUS(d) (DEVICE_X_DATA (d)->x_compose_status) */ #ifdef HAVE_XIM #define DEVICE_X_XIM(d) (DEVICE_X_DATA (d)->xim) diff -r 76b7d63099ad -r 8626e4521993 src/console.c --- a/src/console.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console.c Mon Aug 13 11:07:10 2007 +0200 @@ -100,14 +100,14 @@ { struct console *con = XCONSOLE (obj); -#define MARKED_SLOT(x) ((markobj) (con->x)); +#define MARKED_SLOT(x) ((void) (markobj (con->x))); #include "conslots.h" #undef MARKED_SLOT /* Can be zero for Vconsole_defaults, Vconsole_local_symbols */ if (con->conmeths) { - ((markobj) (con->conmeths->symbol)); + markobj (con->conmeths->symbol); MAYBE_CONMETH (con, mark_console, (con, markobj)); } @@ -285,7 +285,7 @@ set_console_last_nonminibuf_frame (struct console *con, Lisp_Object frame) { - con->_last_nonminibuf_frame = frame; + con->last_nonminibuf_frame = frame; } DEFUN ("consolep", Fconsolep, 1, 1, 0, /* @@ -1141,71 +1141,43 @@ #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); \ +#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) -#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_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) 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)); \ -} 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_DEFAULTS_MAGIC(lname, field_name, magicfun) \ + DEFVAR_SYMVAL_FWD(lname, &(console_local_flags.field_name), \ + SYMVAL_DEFAULT_CONSOLE_FORWARD, magicfun) +#define DEFVAR_CONSOLE_DEFAULTS(lname, field_name) \ + DEFVAR_CONSOLE_DEFAULTS_MAGIC (lname, field_name, 0) static void nuke_all_console_slots (struct console *con, Lisp_Object zap) diff -r 76b7d63099ad -r 8626e4521993 src/console.h --- a/src/console.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/console.h Mon Aug 13 11:07:10 2007 +0200 @@ -37,7 +37,7 @@ always tagged to a particular X window (i.e. frame), which exists on only one screen; therefore the event won't be reported multiple times even if there are multiple devices on - the same physical display. This is an implementational detail + the same physical display. This is an implementation detail specific to X consoles (e.g. under NeXTstep or Windows, this could be different, and input would come directly from the console). */ @@ -209,7 +209,7 @@ int depth); void (*init_image_instance_from_eimage_method) (struct Lisp_Image_Instance *ii, int width, int height, - unsigned char *eimage, + unsigned char *eimage, int dest_mask, Lisp_Object instantiator, Lisp_Object domain); @@ -218,17 +218,17 @@ Lisp_Object fg, Lisp_Object bg); #ifdef HAVE_XPM /* which is more tacky - this or #defines in glyphs.c? */ - void (*xpm_instantiate_method)(Lisp_Object image_instance, + void (*xpm_instantiate_method)(Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, int dest_mask, Lisp_Object domain); #endif #ifdef HAVE_WINDOW_SYSTEM /* which is more tacky - this or #defines in glyphs.c? */ - void (*xbm_instantiate_method)(Lisp_Object image_instance, + void (*xbm_instantiate_method)(Lisp_Object image_instance, Lisp_Object instantiator, - Lisp_Object pointer_fg, + Lisp_Object pointer_fg, Lisp_Object pointer_bg, int dest_mask, Lisp_Object domain); #endif @@ -297,9 +297,9 @@ /* Call a void-returning console method, if it exists */ #define MAYBE_CONTYPE_METH(meth, m, args) do { \ - struct console_methods *_maybe_contype_meth_meth = (meth); \ - if (HAS_CONTYPE_METH_P (_maybe_contype_meth_meth, m)) \ - CONTYPE_METH (_maybe_contype_meth_meth, m, args); \ + struct console_methods *maybe_contype_meth_meth = (meth); \ + if (HAS_CONTYPE_METH_P (maybe_contype_meth_meth, m)) \ + CONTYPE_METH (maybe_contype_meth_meth, m, args); \ } while (0) /* Call a console method, if it exists; otherwise return @@ -531,7 +531,7 @@ #define CONSOLE_SELECTED_DEVICE(con) ((con)->selected_device) #define CONSOLE_SELECTED_FRAME(con) \ DEVICE_SELECTED_FRAME (XDEVICE ((con)->selected_device)) -#define CONSOLE_LAST_NONMINIBUF_FRAME(con) NON_LVALUE ((con)->_last_nonminibuf_frame) +#define CONSOLE_LAST_NONMINIBUF_FRAME(con) NON_LVALUE ((con)->last_nonminibuf_frame) #define CONSOLE_QUIT_CHAR(con) ((con)->quit_char) #define CDFW_CONSOLE(obj) \ diff -r 76b7d63099ad -r 8626e4521993 src/data.c --- a/src/data.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/data.c Mon Aug 13 11:07:10 2007 +0200 @@ -52,7 +52,7 @@ Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp; Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp; -Lisp_Object Qconsp, Qsubrp, Qcompiled_functionp; +Lisp_Object Qconsp, Qsubrp; Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp; Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp; Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p; @@ -77,15 +77,17 @@ int eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2) { - if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) - && (debug_issue_ebola_notices >= 2 - || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))) + if (debug_issue_ebola_notices != -42 /* abracadabra */ && + (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) + && (debug_issue_ebola_notices >= 2 + || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2)))) { - stderr_out("Comparison between integer and character is constant nil ("); + write_c_string ("Comparison between integer and character is constant nil (", + Qexternal_debugging_output); Fprinc (obj1, Qexternal_debugging_output); - stderr_out (" and "); + write_c_string (" and ", Qexternal_debugging_output); Fprinc (obj2, Qexternal_debugging_output); - stderr_out (")\n"); + write_c_string (")\n", Qexternal_debugging_output); debug_short_backtrace (debug_ebola_backtrace_length); } return EQ (obj1, obj2); @@ -207,7 +209,7 @@ } DEFUN ("consp", Fconsp, 1, 1, 0, /* -Return t if OBJECT is a cons cell. +Return t if OBJECT is a cons cell. `nil' is not a cons cell. */ (object)) { @@ -215,7 +217,7 @@ } DEFUN ("atom", Fatom, 1, 1, 0, /* -Return t if OBJECT is not a cons cell. Atoms include nil. +Return t if OBJECT is not a cons cell. `nil' is not a cons cell. */ (object)) { @@ -223,7 +225,7 @@ } DEFUN ("listp", Flistp, 1, 1, 0, /* -Return t if OBJECT is a list. Lists includes nil. +Return t if OBJECT is a list. `nil' is a list. */ (object)) { @@ -231,7 +233,7 @@ } DEFUN ("nlistp", Fnlistp, 1, 1, 0, /* -Return t if OBJECT is not a list. Lists include nil. +Return t if OBJECT is not a list. `nil' is a list. */ (object)) { @@ -263,7 +265,7 @@ } DEFUN ("vectorp", Fvectorp, 1, 1, 0, /* -REturn t if OBJECT is a vector. +Return t if OBJECT is a vector. */ (object)) { @@ -302,8 +304,7 @@ */ (object)) { - return (CONSP (object) || - NILP (object) || + return (LISTP (object) || VECTORP (object) || STRINGP (object) || BIT_VECTORP (object)) @@ -363,14 +364,6 @@ return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil; } -DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* -Return t if OBJECT is a byte-compiled function object. -*/ - (object)) -{ - return COMPILED_FUNCTIONP (object) ? Qt : Qnil; -} - DEFUN ("characterp", Fcharacterp, 1, 1, 0, /* Return t if OBJECT is a character. @@ -551,16 +544,31 @@ */ (object)) { - if (CONSP (object)) return Qcons; - if (SYMBOLP (object)) return Qsymbol; - if (KEYWORDP (object)) return Qkeyword; - if (INTP (object)) return Qinteger; - if (CHARP (object)) return Qcharacter; - if (STRINGP (object)) return Qstring; - if (VECTORP (object)) return Qvector; + switch (XTYPE (object)) + { +#ifndef LRECORD_CONS + case Lisp_Type_Cons: return Qcons; +#endif + +#ifndef LRECORD_SYMBOL + case Lisp_Type_Symbol: return Qsymbol; +#endif - assert (LRECORDP (object)); - return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); +#ifndef LRECORD_STRING + case Lisp_Type_String: return Qstring; +#endif + +#ifndef LRECORD_VECTOR + case Lisp_Type_Vector: return Qvector; +#endif + + case Lisp_Type_Record: + return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); + + case Lisp_Type_Char: return Qcharacter; + + default: return Qinteger; + } } @@ -642,9 +650,9 @@ return newcdr; } -/* Find the function at the end of a chain of symbol function indirections. */ +/* Find the function at the end of a chain of symbol function indirections. -/* If OBJECT is a symbol, find the end of its function chain and + If OBJECT is a symbol, find the end of its function chain and return the value found there. If OBJECT is not a symbol, just return it. If there is a cycle in the function chain, signal a cyclic-function-indirection error. @@ -654,26 +662,25 @@ 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; + if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue; - tortoise = XSYMBOL (tortoise)->function; - + if (count & 1) + tortoise = XSYMBOL (tortoise)->function; if (EQ (hare, tortoise)) return Fsignal (Qcyclic_function_indirection, list1 (object)); } - if (UNBOUNDP (hare) && errorp) - return Fsignal (Qvoid_function, list1 (object)); + if (errorp && UNBOUNDP (hare)) + signal_void_function_error (object); + return hare; } @@ -695,41 +702,44 @@ DEFUN ("aref", Faref, 2, 2, 0, /* Return the element of ARRAY at index INDEX. -ARRAY may be a vector, bit vector, string, or byte-code object. -IDX starts at 0. +ARRAY may be a vector, bit vector, or string. INDEX starts at 0. */ - (array, idx)) + (array, index_)) { - int idxval; + int idx; retry: - CHECK_INT_COERCE_CHAR (idx); /* yuck! */ - idxval = XINT (idx); - if (idxval < 0) + + if (INTP (index_)) idx = XINT (index_); + else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ + else { - lose: - args_out_of_range (array, idx); + index_ = wrong_type_argument (Qinteger_or_char_p, index_); + goto retry; } + + if (idx < 0) goto range_error; + if (VECTORP (array)) { - if (idxval >= XVECTOR_LENGTH (array)) goto lose; - return XVECTOR_DATA (array)[idxval]; + if (idx >= XVECTOR_LENGTH (array)) goto range_error; + return XVECTOR_DATA (array)[idx]; } else if (BIT_VECTORP (array)) { - if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose; - return make_int (bit_vector_bit (XBIT_VECTOR (array), idxval)); + if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error; + return make_int (bit_vector_bit (XBIT_VECTOR (array), idx)); } else if (STRINGP (array)) { - if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose; - return make_char (string_char (XSTRING (array), idxval)); + if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error; + return make_char (string_char (XSTRING (array), idx)); } #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (array)) { /* Weird, gross compatibility kludge */ - return Felt (array, idx); + return Felt (array, index_); } #endif else @@ -738,290 +748,148 @@ 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; + + retry: - CHECK_INT_COERCE_CHAR (idx); /* yuck! */ - if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array)) - array = wrong_type_argument (Qarrayp, array); + if (INTP (index_)) idx = XINT (index_); + else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */ + else + { + index_ = wrong_type_argument (Qinteger_or_char_p, index_); + goto retry; + } - idxval = XINT (idx); - if (idxval < 0) - { - lose: - args_out_of_range (array, idx); - } + 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; -} - -/**********************************************************************/ -/* Compiled-function objects */ -/**********************************************************************/ - -/* 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) -{ - 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; -} - -/* 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) -{ - return b->annotated; -} - -#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; + range_error: + args_out_of_range (array, index_); + return Qnil; /* not reached */ } /**********************************************************************/ /* Arithmetic functions */ /**********************************************************************/ - -Lisp_Object -arithcompare (Lisp_Object num1, Lisp_Object num2, - enum arith_comparison comparison) +typedef struct { - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1); - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2); - -#ifdef LISP_FLOAT_TYPE - if (FLOATP (num1) || FLOATP (num2)) - { - double f1 = FLOATP (num1) ? float_data (XFLOAT (num1)) : XINT (num1); - double f2 = FLOATP (num2) ? float_data (XFLOAT (num2)) : XINT (num2); + int int_p; + union + { + int ival; + double dval; + } c; +} int_or_double; - 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; - } +static void +number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p) +{ + 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 + else + { + obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); + goto retry; } -#endif /* LISP_FLOAT_TYPE */ - - switch (comparison) - { - 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; - } - - abort (); - return Qnil; /* suppress compiler warning */ } -static Lisp_Object -arithcompare_many (enum arith_comparison comparison, - int nargs, Lisp_Object *args) +static double +number_char_or_marker_to_double (Lisp_Object obj) +{ + 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 + else if (FLOATP (obj)) return XFLOAT_DATA (obj); +#endif + else + { + obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); + goto retry; + } +} + +static int +integer_char_or_marker_to_int (Lisp_Object obj) { - for (; --nargs > 0; args++) - if (NILP (arithcompare (*args, *(args + 1), comparison))) - return Qnil; + retry: + if (INTP (obj)) return XINT (obj); + else if (CHARP (obj)) return XCHAR (obj); + else if (MARKERP (obj)) return marker_position (obj); + else + { + obj = wrong_type_argument (Qinteger_char_or_marker_p, obj); + goto retry; + } +} - return Qt; +#define ARITHCOMPARE_MANY(op) \ +{ \ + int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \ + Lisp_Object *args_end = args + nargs; \ + \ + number_char_or_marker_to_int_or_double (*args++, p); \ + \ + while (args < args_end) \ + { \ + number_char_or_marker_to_int_or_double (*args++, q); \ + \ + if (!((p->int_p && q->int_p) ? \ + (p->c.ival op q->c.ival) : \ + ((p->int_p ? (double) p->c.ival : p->c.dval) op \ + (q->int_p ? (double) q->c.ival : q->c.dval)))) \ + return Qnil; \ + \ + { /* swap */ int_or_double *r = p; p = q; q = r; } \ + } \ + return Qt; \ } DEFUN ("=", Feqlsign, 1, MANY, 0, /* @@ -1030,7 +898,7 @@ */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_equal, nargs, args); + ARITHCOMPARE_MANY (==) } DEFUN ("<", Flss, 1, MANY, 0, /* @@ -1039,7 +907,7 @@ */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_less, nargs, args); + ARITHCOMPARE_MANY (<) } DEFUN (">", Fgtr, 1, MANY, 0, /* @@ -1048,7 +916,7 @@ */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_grtr, nargs, args); + ARITHCOMPARE_MANY (>) } DEFUN ("<=", Fleq, 1, MANY, 0, /* @@ -1057,7 +925,7 @@ */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_less_or_equal, nargs, args); + ARITHCOMPARE_MANY (<=) } DEFUN (">=", Fgeq, 1, MANY, 0, /* @@ -1066,7 +934,7 @@ */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_grtr_or_equal, nargs, args); + ARITHCOMPARE_MANY (>=) } DEFUN ("/=", Fneq, 1, MANY, 0, /* @@ -1075,7 +943,28 @@ */ (int nargs, Lisp_Object *args)) { - return arithcompare_many (arith_notequal, nargs, args); + Lisp_Object *args_end = args + nargs; + Lisp_Object *p, *q; + + /* Unlike all the other comparisons, this is an N*N algorithm. + We could use a hash table for nargs > 50 to make this linear. */ + for (p = args; p < args_end; p++) + { + int_or_double iod1, iod2; + number_char_or_marker_to_int_or_double (*p, &iod1); + + for (q = p + 1; q < args_end; q++) + { + number_char_or_marker_to_int_or_double (*q, &iod2); + + if (!((iod1.int_p && iod2.int_p) ? + (iod1.c.ival != iod2.c.ival) : + ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) != + (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval)))) + return Qnil; + } + } + return Qt; } DEFUN ("zerop", Fzerop, 1, 1, 0, /* @@ -1083,14 +972,18 @@ */ (number)) { - CHECK_INT_OR_FLOAT (number); - + retry: + if (INTP (number)) + return EQ (number, Qzero) ? Qt : Qnil; #ifdef LISP_FLOAT_TYPE - if (FLOATP (number)) - return float_data (XFLOAT (number)) == 0.0 ? Qt : Qnil; + else if (FLOATP (number)) + return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil; #endif /* LISP_FLOAT_TYPE */ - - return EQ (number, Qzero) ? Qt : Qnil; + else + { + number = wrong_type_argument (Qnumberp, number); + goto retry; + } } /* Convert between a 32-bit value and a cons of two 16-bit values. @@ -1138,7 +1031,7 @@ { char pigbuf[350]; /* see comments in float_to_string */ - float_to_string (pigbuf, float_data (XFLOAT (num))); + float_to_string (pigbuf, XFLOAT_DATA (num)); return build_string (pigbuf); } #endif /* LISP_FLOAT_TYPE */ @@ -1199,7 +1092,7 @@ if (b == 10) { /* Use the system-provided functions for base 10. */ -#if SIZEOF_EMACS_INT == SIZEOF_INT +#if SIZEOF_EMACS_INT == SIZEOF_INT return make_int (atoi (p)); #elif SIZEOF_EMACS_INT == SIZEOF_LONG return make_int (atol (p)); @@ -1230,144 +1123,6 @@ } } -enum arithop - { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; - - -#ifdef LISP_FLOAT_TYPE -static Lisp_Object -float_arith_driver (double accum, int argnum, enum arithop code, int nargs, - Lisp_Object *args) -{ - REGISTER Lisp_Object val; - double next; - - for (; argnum < nargs; argnum++) - { - /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */ - val = args[argnum]; - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val); - - if (FLOATP (val)) - { - next = float_data (XFLOAT (val)); - } - else - { - args[argnum] = val; /* runs into a compiler bug. */ - next = XINT (args[argnum]); - } - switch (code) - { - 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; - } - } - - return make_float (accum); -} -#endif /* LISP_FLOAT_TYPE */ - -static Lisp_Object -arith_driver (enum arithop code, int nargs, Lisp_Object *args) -{ - Lisp_Object val; - REGISTER int argnum; - REGISTER EMACS_INT accum = 0; - REGISTER EMACS_INT next; - - switch (code) - { - 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 (); - } - - for (argnum = 0; argnum < nargs; argnum++) - { - /* 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) - { - 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; - } - } - - XSETINT (val, accum); - return val; -} DEFUN ("+", Fplus, 0, MANY, 0, /* Return sum of any number of arguments. @@ -1375,17 +1130,66 @@ */ (int nargs, Lisp_Object *args)) { - return arith_driver (Aadd, nargs, args); + EMACS_INT iaccum = 0; + 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 + { + 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, 0, MANY, 0, /* +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)) { - return arith_driver (Asub, nargs, args); + EMACS_INT iaccum; + double daccum; + Lisp_Object *args_end = args + nargs; + int_or_double iod; + + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival; + else + { + daccum = nargs > 1 ? iod.c.dval : - iod.c.dval; + goto do_float; + } + + while (args < args_end) + { + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + iaccum -= iod.c.ival; + else + { + 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, /* @@ -1394,16 +1198,233 @@ */ (int nargs, Lisp_Object *args)) { - return arith_driver (Amult, nargs, 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 + { + 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 ("/", Fquo, 2, MANY, 0, /* +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 + { + daccum = iod.c.dval; + goto divide_floats; + } + } + + 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 */ +} + +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 (Adiv, nargs, args); + EMACS_INT imax; + double dmax; + Lisp_Object *args_end = args + nargs; + int_or_double iod; + + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + imax = iod.c.ival; + else + { + dmax = iod.c.dval; + goto max_floats; + } + + while (args < args_end) + { + number_char_or_marker_to_int_or_double (*args++, &iod); + if (iod.int_p) + { + 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; + } + } + + 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 ("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)) +{ + 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 ("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)) +{ + 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 ("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)) +{ + 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 ("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)) +{ + EMACS_INT bits = 0; + Lisp_Object *args_end = args + nargs; + + while (args < args_end) + bits ^= integer_char_or_marker_to_int (*args++); + + return make_int (bits); +} + +DEFUN ("lognot", Flognot, 1, 1, 0, /* +Return the bitwise complement of NUMBER. +NUMBER may be an integer, marker or character converted to integer. +*/ + (number)) +{ + return make_int (~ integer_char_or_marker_to_int (number)); } DEFUN ("%", Frem, 2, 2, 0, /* @@ -1412,13 +1433,13 @@ */ (num1, num2)) { - CHECK_INT_COERCE_CHAR_OR_MARKER (num1); - CHECK_INT_COERCE_CHAR_OR_MARKER (num2); + int ival1 = integer_char_or_marker_to_int (num1); + int ival2 = integer_char_or_marker_to_int (num2); - if (ZEROP (num2)) + if (ival2 == 0) Fsignal (Qarith_error, Qnil); - return make_int (XINT (num1) % XINT (num2)); + return make_int (ival1 % ival2); } /* Note, ANSI *requires* the presence of the fmod() library routine. @@ -1444,96 +1465,41 @@ */ (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 (dval2 < 0 ? dval1 > 0 : dval1 < 0) + dval1 += dval2; - /* If the "remainder" comes out with the wrong sign, fix it. */ - if (i2 < 0 ? i1 > 0 : i1 < 0) - i1 += i2; - - return make_int (i1); -} - - -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; + + /* 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 ("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); -} + return make_int (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); -} - -DEFUN ("logxor", Flogxor, 0, MANY, 0, /* -Return bitwise-exclusive-or of all the arguments. -Arguments may be integers, or markers or characters converted to integers. -*/ - (int nargs, Lisp_Object *args)) -{ - return arith_driver (Alogxor, nargs, args); + divide_by_zero: + Fsignal (Qarith_error, Qnil); + return Qnil; /* not reached */ } DEFUN ("ash", Fash, 2, 2, 0, /* @@ -1544,7 +1510,7 @@ (value, count)) { CHECK_INT_COERCE_CHAR (value); - CHECK_INT (count); + CONCHECK_INT (count); return make_int (XINT (count) > 0 ? XINT (value) << XINT (count) : @@ -1559,7 +1525,7 @@ (value, count)) { CHECK_INT_COERCE_CHAR (value); - CHECK_INT (count); + CONCHECK_INT (count); return make_int (XINT (count) > 0 ? XUINT (value) << XINT (count) : @@ -1567,44 +1533,41 @@ } DEFUN ("1+", Fadd1, 1, 1, 0, /* -Return NUMBER plus one. NUMBER may be a number or a marker. +Return NUMBER plus one. NUMBER may be a number, character or marker. Markers and characters are converted to integers. */ (number)) { - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number); + retry: + if (INTP (number)) return make_int (XINT (number) + 1); + if (CHARP (number)) return make_int (XCHAR (number) + 1); + if (MARKERP (number)) return make_int (marker_position (number) + 1); #ifdef LISP_FLOAT_TYPE - if (FLOATP (number)) - return make_float (1.0 + float_data (XFLOAT (number))); + if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0); #endif /* LISP_FLOAT_TYPE */ - return make_int (XINT (number) + 1); + number = wrong_type_argument (Qnumber_char_or_marker_p, number); + goto retry; } DEFUN ("1-", Fsub1, 1, 1, 0, /* -Return NUMBER minus one. NUMBER may be a number or a marker. +Return NUMBER minus one. NUMBER may be a number, character or marker. Markers and characters are converted to integers. */ (number)) { - CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number); + retry: + if (INTP (number)) return make_int (XINT (number) - 1); + if (CHARP (number)) return make_int (XCHAR (number) - 1); + if (MARKERP (number)) return make_int (marker_position (number) - 1); #ifdef LISP_FLOAT_TYPE - if (FLOATP (number)) - return make_float (-1.0 + (float_data (XFLOAT (number)))); + if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0); #endif /* LISP_FLOAT_TYPE */ - return make_int (XINT (number) - 1); -} - -DEFUN ("lognot", Flognot, 1, 1, 0, /* -Return the bitwise complement of NUMBER. NUMBER must be an integer. -*/ - (number)) -{ - CHECK_INT (number); - return make_int (~XINT (number)); + number = wrong_type_argument (Qnumber_char_or_marker_p, number); + goto retry; } @@ -1616,7 +1579,7 @@ disappear when no longer in use, i.e. when no longer GC-protected. The basic idea is that we don't mark the elements during GC, but wait for them to be marked elsewhere. If they're not marked, we - remove them. This is analogous to weak hashtables; see the explanation + remove them. This is analogous to weak hash tables; see the explanation there for more info. */ static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ @@ -1644,10 +1607,10 @@ } static int -weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth) +weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct weak_list *w1 = XWEAK_LIST (o1); - struct weak_list *w2 = XWEAK_LIST (o2); + struct weak_list *w1 = XWEAK_LIST (obj1); + struct weak_list *w2 = XWEAK_LIST (obj2); return ((w1->type == w2->type) && internal_equal (w1->list, w2->list, depth + 1)); @@ -1712,7 +1675,7 @@ Lisp_Object rest2; enum weak_list_type type = XWEAK_LIST (rest)->type; - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (rest)) /* The weak list is probably garbage. Ignore it. */ continue; @@ -1735,7 +1698,7 @@ (either because of an external pointer or because of a previous call to this function), and likewise for all the rest of the elements in the list, so we can stop now. */ - if ((*obj_marked_p) (rest2)) + if (obj_marked_p (rest2)) break; elem = XCAR (rest2); @@ -1743,7 +1706,7 @@ switch (type) { case WEAK_LIST_SIMPLE: - if ((*obj_marked_p) (elem)) + if (obj_marked_p (elem)) need_to_mark_cons = 1; break; @@ -1754,8 +1717,8 @@ need_to_mark_cons = 1; need_to_mark_elem = 1; } - else if ((*obj_marked_p) (XCAR (elem)) && - (*obj_marked_p) (XCDR (elem))) + else if (obj_marked_p (XCAR (elem)) && + obj_marked_p (XCDR (elem))) { need_to_mark_cons = 1; /* We still need to mark elem, because it's @@ -1771,7 +1734,7 @@ need_to_mark_cons = 1; need_to_mark_elem = 1; } - else if ((*obj_marked_p) (XCAR (elem))) + else if (obj_marked_p (XCAR (elem))) { need_to_mark_cons = 1; /* We still need to mark elem and XCDR (elem); @@ -1787,7 +1750,7 @@ need_to_mark_cons = 1; need_to_mark_elem = 1; } - else if ((*obj_marked_p) (XCDR (elem))) + else if (obj_marked_p (XCDR (elem))) { need_to_mark_cons = 1; /* We still need to mark elem and XCAR (elem); @@ -1800,9 +1763,9 @@ abort (); } - if (need_to_mark_elem && ! (*obj_marked_p) (elem)) + if (need_to_mark_elem && ! obj_marked_p (elem)) { - (*markobj) (elem); + markobj (elem); did_mark = 1; } @@ -1824,9 +1787,9 @@ /* In case of imperfect list, need to mark the final cons because we're not removing it */ - if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2)) + if (!GC_NILP (rest2) && ! obj_marked_p (rest2)) { - (markobj) (rest2); + markobj (rest2); did_mark = 1; } } @@ -1843,7 +1806,7 @@ !GC_NILP (rest); rest = XWEAK_LIST (rest)->next_weak) { - if (! ((*obj_marked_p) (rest))) + if (! (obj_marked_p (rest))) { /* This weak list itself is garbage. Remove it from the list. */ if (GC_NILP (prev)) @@ -1873,7 +1836,7 @@ have been marked in finish_marking_weak_lists(). -- otherwise, it's not marked and should disappear. */ - if (!(*obj_marked_p) (rest2)) + if (! obj_marked_p (rest2)) { /* bye bye :-( */ if (GC_NILP (prev2)) @@ -2086,14 +2049,17 @@ "Attempt to set a constant symbol", Qerror); deferror (&Qinvalid_read_syntax, "invalid-read-syntax", "Invalid read syntax", Qerror); + + /* Generated by list traversal macros */ deferror (&Qmalformed_list, "malformed-list", "Malformed list", Qerror); deferror (&Qmalformed_property_list, "malformed-property-list", - "Malformed property list", Qerror); + "Malformed property list", Qmalformed_list); deferror (&Qcircular_list, "circular-list", "Circular list", Qerror); deferror (&Qcircular_property_list, "circular-property-list", - "Circular property list", Qerror); + "Circular property list", Qcircular_list); + deferror (&Qinvalid_function, "invalid-function", "Invalid function", Qerror); deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments", @@ -2146,7 +2112,6 @@ defsymbol (&Qbitp, "bitp"); defsymbol (&Qbit_vectorp, "bit-vector-p"); defsymbol (&Qvectorp, "vectorp"); - defsymbol (&Qcompiled_functionp, "compiled-function-p"); defsymbol (&Qchar_or_string_p, "char-or-string-p"); defsymbol (&Qmarkerp, "markerp"); defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p"); @@ -2167,6 +2132,7 @@ DEFSUBR (Feq); DEFSUBR (Fold_eq); DEFSUBR (Fnull); + Ffset (intern ("not"), intern ("null")); DEFSUBR (Flistp); DEFSUBR (Fnlistp); DEFSUBR (Ftrue_list_p); @@ -2202,7 +2168,6 @@ DEFSUBR (Fsubr_min_args); DEFSUBR (Fsubr_max_args); DEFSUBR (Fsubr_interactive); - DEFSUBR (Fcompiled_function_p); DEFSUBR (Ftype_of); DEFSUBR (Fcar); DEFSUBR (Fcdr); @@ -2214,17 +2179,6 @@ DEFSUBR (Faref); DEFSUBR (Faset); - DEFSUBR (Fcompiled_function_instructions); - DEFSUBR (Fcompiled_function_constants); - DEFSUBR (Fcompiled_function_stack_depth); - DEFSUBR (Fcompiled_function_arglist); - DEFSUBR (Fcompiled_function_interactive); - DEFSUBR (Fcompiled_function_doc_string); - DEFSUBR (Fcompiled_function_domain); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - DEFSUBR (Fcompiled_function_annotation); -#endif - DEFSUBR (Fnumber_to_string); DEFSUBR (Fstring_to_number); DEFSUBR (Feqlsign); @@ -2266,9 +2220,9 @@ #ifdef DEBUG_XEMACS DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* -If non-nil, note when your code may be suffering from char-int confoundance. +If non-zero, note when your code may be suffering from char-int confoundance. That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', -etc. where a int and a char with the same value are being compared, +etc. where an int and a char with the same value are being compared, it will issue a notice on stderr to this effect, along with a backtrace. In such situations, the result would be different in XEmacs 19 versus XEmacs 20, and you probably don't want this. diff -r 76b7d63099ad -r 8626e4521993 src/database.c --- a/src/database.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/database.c Mon Aug 13 11:07:10 2007 +0200 @@ -27,6 +27,7 @@ #include #include "lisp.h" #include "sysfile.h" +#include "buffer.h" #include #ifndef HAVE_DATABASE @@ -65,29 +66,34 @@ Lisp_Object Qdbm; #endif /* HAVE_DBM */ +#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 + Lisp_Object Qdatabasep; -typedef enum { DB_DBM, DB_BERKELEY, DB_IS_UNKNOWN } XEMACS_DB_TYPE; - struct Lisp_Database; +typedef struct Lisp_Database Lisp_Database; typedef struct { - Lisp_Object (*get_subtype) (struct Lisp_Database *); - Lisp_Object (*get_type) (struct Lisp_Database *); - Lisp_Object (*get) (struct Lisp_Database *, Lisp_Object); - int (*put) (struct Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); - int (*rem) (struct Lisp_Database *, Lisp_Object); - void (*map) (struct Lisp_Database *, Lisp_Object); - void (*close) (struct Lisp_Database *); - Lisp_Object (*last_error) (struct Lisp_Database *); + Lisp_Object (*get_subtype) (Lisp_Database *); + Lisp_Object (*get_type) (Lisp_Database *); + Lisp_Object (*get) (Lisp_Database *, Lisp_Object); + int (*put) (Lisp_Database *, Lisp_Object, Lisp_Object, Lisp_Object); + int (*rem) (Lisp_Database *, Lisp_Object); + void (*map) (Lisp_Database *, Lisp_Object); + void (*close) (Lisp_Database *); + Lisp_Object (*last_error) (Lisp_Database *); } DB_FUNCS; struct Lisp_Database { struct lcrecord_header header; Lisp_Object fname; - XEMACS_DB_TYPE type; int mode; int access_; int dberrno; @@ -104,7 +110,7 @@ #endif }; -#define XDATABASE(x) XRECORD (x, database, struct Lisp_Database) +#define XDATABASE(x) XRECORD (x, database, Lisp_Database) #define XSETDATABASE(x, p) XSETRECORD (x, p, database) #define DATABASEP(x) RECORDP (x, database) #define GC_DATABASEP(x) GC_RECORDP (x, database) @@ -119,11 +125,10 @@ } while (0) -static struct Lisp_Database * +static Lisp_Database * allocate_database (void) { - struct Lisp_Database *db = - alloc_lcrecord_type (struct Lisp_Database, lrecord_database); + Lisp_Database *db = alloc_lcrecord_type (Lisp_Database, lrecord_database); db->fname = Qnil; db->live_p = 0; @@ -136,7 +141,6 @@ db->access_ = 0; db->mode = 0; db->dberrno = 0; - db->type = DB_IS_UNKNOWN; #ifdef MULE db->coding_system = Fget_coding_system (Qbinary); #endif @@ -146,9 +150,9 @@ static Lisp_Object mark_database (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct Lisp_Database *db = XDATABASE (obj); + Lisp_Database *db = XDATABASE (obj); - ((markobj) (db->fname)); + markobj (db->fname); return Qnil; } @@ -156,7 +160,7 @@ print_database (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { char buf[64]; - struct Lisp_Database *db = XDATABASE (obj); + Lisp_Database *db = XDATABASE (obj); if (print_readably) error ("printing unreadable object #", db->header.uid); @@ -176,12 +180,12 @@ static void finalize_database (void *header, int for_disksave) { - struct Lisp_Database *db = (struct Lisp_Database *) header; + Lisp_Database *db = (Lisp_Database *) header; if (for_disksave) { Lisp_Object obj; - XSETOBJ (obj, Lisp_Type_Record, (void *) db); + XSETDATABASE (obj, db); signal_simple_error ("Can't dump an emacs containing database objects", obj); @@ -192,14 +196,14 @@ DEFINE_LRECORD_IMPLEMENTATION ("database", database, mark_database, print_database, finalize_database, 0, 0, - struct Lisp_Database); + Lisp_Database); DEFUN ("close-database", Fclose_database, 1, 1, 0, /* Close database DATABASE. */ (database)) { - struct Lisp_Database *db; + Lisp_Database *db; CHECK_LIVE_DATABASE (database); db = XDATABASE (database); db->funcs->close (db); @@ -255,7 +259,7 @@ #ifdef HAVE_DBM static void -dbm_map (struct Lisp_Database *db, Lisp_Object func) +dbm_map (Lisp_Database *db, Lisp_Object func) { datum keydatum, valdatum; Lisp_Object key, val; @@ -272,7 +276,7 @@ } static Lisp_Object -dbm_get (struct Lisp_Database *db, Lisp_Object key) +dbm_get (Lisp_Database *db, Lisp_Object key) { datum keydatum, valdatum; @@ -286,7 +290,7 @@ } static int -dbm_put (struct Lisp_Database *db, +dbm_put (Lisp_Database *db, Lisp_Object key, Lisp_Object val, Lisp_Object replace) { datum keydatum, valdatum; @@ -301,7 +305,7 @@ } static int -dbm_remove (struct Lisp_Database *db, Lisp_Object key) +dbm_remove (Lisp_Database *db, Lisp_Object key) { datum keydatum; @@ -312,25 +316,25 @@ } static Lisp_Object -dbm_type (struct Lisp_Database *db) +dbm_type (Lisp_Database *db) { return Qdbm; } static Lisp_Object -dbm_subtype (struct Lisp_Database *db) +dbm_subtype (Lisp_Database *db) { return Qnil; } static Lisp_Object -dbm_lasterr (struct Lisp_Database *db) +dbm_lasterr (Lisp_Database *db) { return lisp_strerror (db->dberrno); } static void -dbm_closeit (struct Lisp_Database *db) +dbm_closeit (Lisp_Database *db) { if (db->dbm_handle) { @@ -354,13 +358,13 @@ #ifdef HAVE_BERKELEY_DB static Lisp_Object -berkdb_type (struct Lisp_Database *db) +berkdb_type (Lisp_Database *db) { return Qberkeley_db; } static Lisp_Object -berkdb_subtype (struct Lisp_Database *db) +berkdb_subtype (Lisp_Database *db) { if (!db->db_handle) return Qnil; @@ -375,23 +379,20 @@ } static Lisp_Object -berkdb_lasterr (struct Lisp_Database *db) +berkdb_lasterr (Lisp_Database *db) { return lisp_strerror (db->dberrno); } static Lisp_Object -berkdb_get (struct Lisp_Database *db, Lisp_Object key) +berkdb_get (Lisp_Database *db, Lisp_Object key) { - /* #### Needs mule-izing */ DBT keydatum, valdatum; int status = 0; -#if DB_VERSION_MAJOR == 2 - /* Always initialize keydatum, valdatum. */ + /* DB Version 2 requires DBT's to be zeroed before use. */ xzero (keydatum); xzero (valdatum); -#endif /* DV_VERSION_MAJOR = 2 */ keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); @@ -403,6 +404,7 @@ #endif /* DB_VERSION_MAJOR */ if (!status) + /* #### Not mule-ized! will crash! */ return make_string ((Bufbyte *) valdatum.data, valdatum.size); #if DB_VERSION_MAJOR == 1 @@ -415,7 +417,7 @@ } static int -berkdb_put (struct Lisp_Database *db, +berkdb_put (Lisp_Database *db, Lisp_Object key, Lisp_Object val, Lisp_Object replace) @@ -423,11 +425,9 @@ DBT keydatum, valdatum; int status = 0; -#if DB_VERSION_MAJOR == 2 - /* Always initalize keydatum, valdatum. */ + /* DB Version 2 requires DBT's to be zeroed before use. */ xzero (keydatum); xzero (valdatum); -#endif /* DV_VERSION_MAJOR = 2 */ keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); @@ -447,15 +447,13 @@ } static int -berkdb_remove (struct Lisp_Database *db, Lisp_Object key) +berkdb_remove (Lisp_Database *db, Lisp_Object key) { DBT keydatum; int status; -#if DB_VERSION_MAJOR == 2 - /* Always initialize keydatum. */ + /* DB Version 2 requires DBT's to be zeroed before use. */ xzero (keydatum); -#endif /* DV_VERSION_MAJOR = 2 */ keydatum.data = XSTRING_DATA (key); keydatum.size = XSTRING_LENGTH (key); @@ -479,13 +477,16 @@ } static void -berkdb_map (struct Lisp_Database *db, Lisp_Object func) +berkdb_map (Lisp_Database *db, Lisp_Object func) { DBT keydatum, valdatum; Lisp_Object key, val; DB *dbp = db->db_handle; int status; + xzero (keydatum); + xzero (valdatum); + #if DB_VERSION_MAJOR == 1 for (status = dbp->seq (dbp, &keydatum, &valdatum, R_FIRST); status == 0; @@ -498,9 +499,6 @@ } #else DBC *dbcp; - /* Initialize the key/data pair so the flags aren't set. */ - xzero (keydatum); - xzero (valdatum); status = dbp->cursor (dbp, NULL, &dbcp); for (status = dbcp->c_get (dbcp, &keydatum, &valdatum, DB_FIRST); @@ -517,7 +515,7 @@ } static void -berkdb_close (struct Lisp_Database *db) +berkdb_close (Lisp_Database *db) { if (db->db_handle) { @@ -571,7 +569,7 @@ /* This function can GC */ int modemask; int accessmask = 0; - struct Lisp_Database *db = NULL; + Lisp_Database *db = NULL; char *filename; struct gcpro gcpro1, gcpro2; @@ -579,7 +577,8 @@ GCPRO2 (file, access_); file = Fexpand_file_name (file, Qnil); UNGCPRO; - filename = (char *) XSTRING_DATA (file); + + GET_C_CHARPTR_EXT_FILENAME_DATA_ALLOCA (XSTRING_DATA (file), filename); if (NILP (access_)) { @@ -622,7 +621,6 @@ db = allocate_database (); db->dbm_handle = dbase; - db->type = DB_DBM; db->funcs = &ndbm_func_block; goto db_done; } @@ -676,7 +674,6 @@ db = allocate_database (); db->db_handle = dbase; - db->type = DB_BERKELEY; db->funcs = &berk_func_block; goto db_done; } @@ -709,7 +706,7 @@ CHECK_STRING (key); CHECK_STRING (value); { - struct Lisp_Database *db = XDATABASE (database); + Lisp_Database *db = XDATABASE (database); int status = db->funcs->put (db, key, value, replace); return status ? Qt : Qnil; } @@ -723,7 +720,7 @@ CHECK_LIVE_DATABASE (database); CHECK_STRING (key); { - struct Lisp_Database *db = XDATABASE (database); + Lisp_Database *db = XDATABASE (database); int status = db->funcs->rem (db, key); return status ? Qt : Qnil; } @@ -738,7 +735,7 @@ CHECK_LIVE_DATABASE (database); CHECK_STRING (key); { - struct Lisp_Database *db = XDATABASE (database); + Lisp_Database *db = XDATABASE (database); Lisp_Object retval = db->funcs->get (db, key); return NILP (retval) ? default_ : retval; } @@ -795,4 +792,13 @@ #ifdef HAVE_BERKELEY_DB Fprovide (Qberkeley_db); #endif + +#if 0 /* #### implement me! */ +#ifdef MULE + DEFVAR_LISP ("database-coding-system", &Vdatabase_coding_system /* +Coding system used to convert data in database files. +*/ ); + Vdatabase_coding_system = Qnil; +#endif +#endif /* 0 */ } diff -r 76b7d63099ad -r 8626e4521993 src/dbxrc --- a/src/dbxrc Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dbxrc Mon Aug 13 11:07:10 2007 +0200 @@ -23,7 +23,7 @@ # You can use this file to debug XEmacs using Sun WorkShop's dbx. # Add the contents of this file to $HOME/.dbxrc or # Source the contents of this file with something like: -# test -r ./dbxrc && . ./dbxrc +# if test -r ./dbxrc; then . ./dbxrc; fi # Some functions defined here require a running process, but most # don't. Considerable effort has been expended to this end. @@ -76,9 +76,17 @@ # Various dbx bugs cause ugliness in following code function decode_object { - test -z "$xemacs_initted" && XEmacsInit - obj=$[*(void**)(&$1)] - test "$obj" = "(nil)" && obj="0x0" + if test -z "$xemacs_initted"; then XEmacsInit; fi; + if test $dbg_USE_UNION_TYPE = 1; then + # Repeat after me... dbx sux, dbx sux, dbx sux... + # Allow both `pobj Qnil' and `pobj 0x82746834' to work + case $(whatis $1) in + *Lisp_Object*) obj="$[(unsigned long)(($1).i)]";; + *) obj="$[(unsigned long)($1)]";; + esac + else + obj="$[(unsigned long)($1)]"; + fi if test $dbg_USE_MINIMAL_TAGBITS = 1; then if test $[(int)($obj & 1)] = 1; then # It's an int @@ -91,13 +99,22 @@ else # It's a record pointer val=$[(void*)$obj] + if test "$val" = "(nil)"; then type=null_pointer; fi fi fi else # not dbg_USE_MINIMAL_TAGBITS - val=$[(void*)($obj & $dbg_valmask)] - test "$val" = "(nil)" && val="0x0" type=$[(int)(((unsigned long long)($obj & $dbg_typemask)) >> ($dbg_valbits + 1))] + if test "$[$type == Lisp_Type_Int]" = 1; then + val=$[(int)($obj & $dbg_valmask)] + elif test "$[$type == Lisp_Type_Char]" = 1; then + val=$[(int)($obj & $dbg_valmask)] + else + val=$[(void*)($obj & $dbg_valmask)] + if test "$val" = "(nil)"; then type=null_pointer; fi + fi + #val=$[(void*)($obj & $dbg_valmask)] + #printvar val type obj fi if test $type = $dbg_Lisp_Type_Record; then @@ -126,6 +143,7 @@ elif test $type = $dbg_Lisp_Type_String; then echo "string" elif test $type = $dbg_Lisp_Type_Vector; then echo "vector" elif test $type = $dbg_Lisp_Type_Cons; then echo "cons" + elif test $type = null_pointer; then echo "$type" else echo "record type with name: $[((struct lrecord_implementation *)$imp)->name]" fi @@ -227,7 +245,7 @@ elif lrecord_type_p console; then pstruct console elif lrecord_type_p database; then - pstruct database + pstruct Lisp_Database elif lrecord_type_p device; then pstruct device elif lrecord_type_p event; then @@ -248,12 +266,12 @@ pstruct frame elif lrecord_type_p glyph; then pstruct Lisp_Glyph - elif lrecord_type_p hashtable; then - pstruct hashtable + elif lrecord_type_p hash_table; then + pstruct Lisp_Hash_Table elif lrecord_type_p image_instance; then pstruct Lisp_Image_Instance elif lrecord_type_p keymap; then - pstruct keymap + pstruct Lisp_Keymap elif lrecord_type_p lcrecord_list; then pstruct lcrecord_list elif lrecord_type_p lstream; then @@ -294,6 +312,8 @@ pstruct window elif lrecord_type_p window_configuration; then pstruct window_config + elif test "$type" = "null_pointer"; then + echo "Lisp Object is a null pointer!!" else echo "Unknown Lisp Object type" print $1 @@ -307,6 +327,7 @@ } dbxenv suppress_startup_message 4.0 +dbxenv mt_watchpoints on function dp_core { print ((struct x_frame *)(((struct frame*)(Fselected_frame(Qnil)&0x00FFFFFF))->frame_data))->widget->core diff -r 76b7d63099ad -r 8626e4521993 src/debug.c --- a/src/debug.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/debug.c Mon Aug 13 11:07:10 2007 +0200 @@ -59,10 +59,10 @@ static Lisp_Object xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type) { - int flag = ((op == ADD) ? 1 : 0); + int flag = (op == ADD) ? 1 : 0; Lisp_Object retval = Qnil; -#define FROB(item)\ +#define FROB(item) \ if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item)) \ { \ if (op == ADD || op == DELETE || op == INIT) \ @@ -75,7 +75,7 @@ else if (op == SETTYPE) \ active_debug_classes.types_of_##item = XINT (type); \ else if (op == TYPE) \ - retval = make_int (active_debug_classes.types_of_##item), Qnil; \ + retval = make_int (active_debug_classes.types_of_##item); \ if (op == INIT) active_debug_classes.types_of_##item = VALBITS; \ } diff -r 76b7d63099ad -r 8626e4521993 src/depend --- a/src/depend Mon Aug 13 11:06:08 2007 +0200 +++ b/src/depend Mon Aug 13 11:07:10 2007 +0200 @@ -24,21 +24,21 @@ #ifdef HAVE_X_WINDOWS balloon-x.o: $(LISP_H) balloon_help.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h xintrinsic.h console-x.o: $(LISP_H) conslots.h console-x.h console.h lisp-disunion.h lisp-union.h lrecord.h process.h redisplay.h symeval.h symsinit.h xintrinsic.h -device-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmu.h -dialog-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h EmacsShell.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h +device-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h elhash.h events.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmu.h +dialog-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h frame-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h EmacsShell.h ExternalShell.h buffer.h bufslots.h conslots.h console-x.h console.h device.h dragdrop.h events-mod.h events.h extents.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h offix-types.h offix.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h xintrinsicp.h xmprimitivep.h xmu.h glyphs-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h bitmaps.h buffer.h bufslots.h conslots.h console-x.h console.h device.h file-coding.h frame.h frameslots.h glyphs-x.h glyphs.h imgproc.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h xintrinsic.h xmu.h gui-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h conslots.h console-x.h console.h device.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h xintrinsic.h input-method-xfs.o: $(LISP_H) EmacsFrame.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h input-method-xlib.o: $(LISP_H) EmacsFrame.h buffer.h bufslots.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h -menubar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h EmacsShell.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h +menubar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h events.h frame.h frameslots.h gui-x.h gui.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h xintrinsic.h objects-x.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h specifier.h symeval.h symsinit.h xintrinsic.h redisplay-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h conslots.h console-x.h console.h debug.h device.h faces.h file-coding.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-ccl.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysproc.h systime.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmprimitivep.h -scrollbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsManager.h conslots.h console-x.h console.h device.h frame.h frameslots.h glyphs-x.h glyphs.h gui-x.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h -toolbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h buffer.h bufslots.h conslots.h console-x.h console.h device.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xgccache.h xintrinsic.h xintrinsicp.h xmprimitivep.h +scrollbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h conslots.h console-x.h console.h device.h frame.h frameslots.h glyphs-x.h glyphs.h gui-x.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar-x.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h +toolbar-x.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h conslots.h console-x.h console.h device.h faces.h frame.h frameslots.h glyphs-x.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xintrinsic.h xintrinsicp.h xmprimitivep.h #endif #ifdef HAVE_DATABASE -database.o: $(LISP_H) database.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h +database.o: $(LISP_H) buffer.h bufslots.h database.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfile.h #endif #ifdef MULE mule-canna.o: $(LISP_H) buffer.h bufslots.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h @@ -61,65 +61,67 @@ EmacsShell-sub.o: EmacsShell.h EmacsShellP.h config.h xintrinsic.h xintrinsicp.h EmacsShell.o: EmacsShell.h ExternalShell.h config.h xintrinsicp.h abbrev.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h symeval.h symsinit.h syntax.h window.h winslots.h -alloc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h conslots.h console.h device.h elhash.h events.h extents.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h puresize.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h systime.h toolbar.h window.h winslots.h +alloc.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h conslots.h console.h device.h elhash.h events.h extents.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h puresize-adjust.h puresize.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h systime.h toolbar.h window.h winslots.h alloca.o: config.h balloon_help.o: balloon_help.h config.h xintrinsic.h blocktype.o: $(LISP_H) blocktype.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h buffer.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syntax.h sysdep.h sysfile.h toolbar.h window.h winslots.h -bytecode.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +bytecode.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h syntax.h callint.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h events.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h symeval.h symsinit.h systime.h window.h winslots.h -callproc.o: $(LISP_H) buffer.h bufslots.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h nt.h paths.h process.h redisplay.h scrollbar.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h window.h winslots.h -casefiddle.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +callproc.o: $(LISP_H) buffer.h bufslots.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h nt.h process.h redisplay.h scrollbar.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h window.h winslots.h +casefiddle.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h casetab.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h -chartab.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +chartab.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h cm.o: $(LISP_H) conslots.h console-tty.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h -cmdloop.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h macros.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h +cmdloop.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h cmds.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h console-stream.o: $(LISP_H) conslots.h console-stream.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h -console-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h faces.h file-coding.h frame.h frameslots.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systty.h toolbar.h +console-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h faces.h file-coding.h frame.h frameslots.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systty.h toolbar.h console.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h data.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfloat.h syssignal.h debug.o: $(LISP_H) bytecode.h debug.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h device-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h events.h faces.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h device.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h events.h faces.h frame.h frameslots.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h toolbar.h window.h winslots.h +dgif_lib.o: gifrlib.h dialog.o: $(LISP_H) conslots.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h -dired.o: $(LISP_H) buffer.h bufslots.h commands.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h opaque.h regex.h symeval.h symsinit.h sysdir.h sysfile.h +dired.o: $(LISP_H) buffer.h bufslots.h commands.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h opaque.h regex.h symeval.h symsinit.h sysdir.h sysfile.h syspwd.h systime.h dll.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysdll.h doc.o: $(LISP_H) buffer.h bufslots.h bytecode.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h sysfile.h doprnt.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h dragdrop.o: $(LISP_H) dragdrop.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h dynarr.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h ecrt0.o: config.h -editfns.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syspwd.h systime.h toolbar.h window.h winslots.h +editfns.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syspwd.h systime.h toolbar.h window.h winslots.h eldap.o: $(LISP_H) eldap.h lisp-disunion.h lisp-union.h lrecord.h opaque.h symeval.h symsinit.h sysdep.h -elhash.o: $(LISP_H) bytecode.h elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -emacs.o: $(LISP_H) backtrace.h buffer.h bufslots.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h paths.h process.h symeval.h symsinit.h sysdep.h sysdll.h sysfile.h syssignal.h systime.h systty.h +elhash.o: $(LISP_H) bytecode.h elhash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h +emacs.o: $(LISP_H) backtrace.h buffer.h bufslots.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h paths.h process.h redisplay.h symeval.h symsinit.h sysdep.h sysdll.h sysfile.h syssignal.h systime.h systty.h eval.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h commands.h conslots.h console.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h symeval.h symsinit.h -event-Xt.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h blocktype.h buffer.h bufslots.h commands.h conslots.h console-tty.h console-x.h console.h device.h dragdrop.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h offix-types.h offix.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h toolbar.h xintrinsic.h xintrinsicp.h +event-Xt.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h blocktype.h buffer.h bufslots.h conslots.h console-tty.h console-x.h console.h device.h dragdrop.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-x.h objects.h offix-types.h offix.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h toolbar.h xintrinsic.h xintrinsicp.h event-stream.o: $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h blocktype.h buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h elhash.h events-mod.h events.h file-coding.h frame.h frameslots.h gui-x.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h lstream.h macros.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h syssignal.h systime.h toolbar.h window.h winslots.h xintrinsic.h event-tty.o: $(LISP_H) conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h process.h scrollbar.h specifier.h symeval.h symsinit.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h event-unixoid.o: $(LISP_H) conslots.h console-stream.h console-tty.h console.h device.h events.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h process.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h events.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console-x.h console.h device.h events-mod.h events.h extents.h frame.h frameslots.h glyphs.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h xintrinsic.h -extents.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h hash.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h -faces.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h hash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h +extents.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h +faces.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h extents.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h file-coding.o: $(LISP_H) buffer.h bufslots.h elhash.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-ccl.h mule-charset.h symeval.h symsinit.h fileio.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h ndir.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysdir.h sysfile.h sysproc.h syspwd.h systime.h toolbar.h window.h winslots.h filelock.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h paths.h symeval.h symsinit.h sysdir.h sysfile.h syspwd.h syssignal.h filemode.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h floatfns.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfloat.h syssignal.h -fns.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h +fns.o: $(LISP_H) buffer.h bufslots.h bytecode.h conslots.h console.h device.h events.h extents.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h font-lock.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h frame-tty.o: $(LISP_H) conslots.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systime.h systty.h toolbar.h -frame.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h extents.h faces.h frame.h frameslots.h glyphs.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h systime.h toolbar.h window.h winslots.h +frame.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h extents.h faces.h frame.h frameslots.h glyphs.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h free-hook.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h general.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h getloadavg.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h -glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h file-coding.h frame.h frameslots.h glyphs.h imgproc.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h +gif_io.o: gifrlib.h +glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h file-coding.h frame.h frameslots.h gifrlib.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h toolbar.h glyphs.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h elhash.h faces.h frame.h frameslots.h glyphs.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h gmalloc.o: config.h getpagesize.h gpmevent.o: $(LISP_H) conslots.h console-tty.h console.h device.h events-mod.h events.h gpmevent.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h gui.o: $(LISP_H) bytecode.h gui.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -hash.o: $(LISP_H) elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h +hash.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h hftctl.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h hpplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h imgproc.o: $(LISP_H) imgproc.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h @@ -128,11 +130,11 @@ input-method-motif.o: $(LISP_H) EmacsFrame.h conslots.h console-x.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h xintrinsic.h insdel.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h extents.h frame.h frameslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h intl.o: $(LISP_H) bytecode.h conslots.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -keymap.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h conslots.h console.h device.h elhash.h events-mod.h events.h frame.h frameslots.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h +keymap.o: $(LISP_H) buffer.h bufslots.h bytecode.h conslots.h console.h device.h elhash.h events-mod.h events.h frame.h frameslots.h insdel.h keymap.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h libsst.o: $(LISP_H) libsst.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h -line-number.o: $(LISP_H) buffer.h bufslots.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h +line-number.o: $(LISP_H) buffer.h bufslots.h line-number.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h linuxplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h syssignal.h -lread.o: $(LISP_H) buffer.h bufslots.h bytecode.h commands.h file-coding.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h paths.h symeval.h symsinit.h sysfile.h sysfloat.h +lread.o: $(LISP_H) buffer.h bufslots.h bytecode.h elhash.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h symeval.h symsinit.h sysfile.h sysfloat.h lstream.o: $(LISP_H) buffer.h bufslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h sysfile.h macros.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h frame.h frameslots.h keymap.h lisp-disunion.h lisp-union.h lrecord.h macros.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h malloc.o: config.h getpagesize.h @@ -140,7 +142,7 @@ md5.o: $(LISP_H) buffer.h bufslots.h file-coding.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h symeval.h symsinit.h menubar.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h frame.h frameslots.h gui.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h minibuf.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-stream.h console.h device.h events.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h window.h winslots.h -nas.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h +nas.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h nt.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h nt.h ntheap.h symeval.h symsinit.h sysproc.h syssignal.h systime.h ntheap.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h ntheap.h symeval.h symsinit.h ntplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysfile.h @@ -151,23 +153,23 @@ opaque.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h opaque.h symeval.h symsinit.h print.o: $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h conslots.h console-stream.h console-tty.h console.h device.h extents.h frame.h frameslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h syssignal.h systty.h toolbar.h process-nt.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h process.h procimpl.h symeval.h symsinit.h sysdep.h -process-unix.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h -process.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h -profile.o: $(LISP_H) backtrace.h bytecode.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h systime.h +process-unix.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h +process.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h events.h file-coding.h frame.h frameslots.h hash.h insdel.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h opaque.h process.h procimpl.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h +profile.o: $(LISP_H) backtrace.h bytecode.h elhash.h hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h syssignal.h systime.h pure.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h puresize-adjust.h puresize.h symeval.h symsinit.h ralloc.o: $(LISP_H) getpagesize.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h rangetab.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h rangetab.h symeval.h symsinit.h realpath.o: config.h -redisplay-output.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h debug.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h toolbar.h window.h winslots.h +redisplay-output.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h redisplay-tty.o: $(LISP_H) buffer.h bufslots.h conslots.h console-tty.h console.h device.h events.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h lstream.h mule-charset.h objects-tty.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h systty.h toolbar.h window.h winslots.h -redisplay.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-tty.h console.h debug.h device.h extents.h faces.h file-coding.h frame.h frameslots.h glyphs.h gui.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h objects.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h window.h winslots.h +redisplay.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-tty.h console.h debug.h device.h elhash.h extents.h faces.h file-coding.h frame.h frameslots.h glyphs.h gui.h insdel.h line-number.h lisp-disunion.h lisp-union.h lrecord.h menubar.h mule-charset.h objects.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h syssignal.h systty.h toolbar.h window.h winslots.h regex.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h regex.h symeval.h symsinit.h syntax.h scrollbar.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h -search.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h regex.h symeval.h symsinit.h syntax.h +search.o: $(LISP_H) buffer.h bufslots.h chartab.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h regex.h symeval.h symsinit.h syntax.h sgiplay.o: $(LISP_H) libst.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sheap.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h sheap-adjust.h symeval.h symsinit.h signal.o: $(LISP_H) conslots.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h syssignal.h systime.h toolbar.h -sound.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h symeval.h symsinit.h sysdep.h xintrinsic.h +sound.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h redisplay.h symeval.h symsinit.h sysdep.h xintrinsic.h specifier.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h opaque.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h strcat.o: config.h strcmp.o: config.h @@ -177,7 +179,7 @@ sunplay.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h sysdep.h syssignal.h sunpro.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h symbols.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h elhash.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h -syntax.o: $(LISP_H) buffer.h bufslots.h chartab.h commands.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h +syntax.o: $(LISP_H) buffer.h bufslots.h chartab.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h syntax.h sysdep.o: $(LISP_H) buffer.h bufslots.h conslots.h console-stream.h console-tty.h console.h device.h events.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h ndir.h ntheap.h process.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h sysdep.h sysdir.h sysfile.h syssignal.h systime.h systty.h syswait.h toolbar.h window.h winslots.h sysdll.o: config.h sysdll.h termcap.o: $(LISP_H) conslots.h console.h device.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h @@ -199,11 +201,11 @@ unexhp9k3.o: config.h sysdep.h unexhp9k800.o: config.h unexmips.o: config.h getpagesize.h -unexnt.o: ntheap.h +unexnt.o: config.h ntheap.h unexsunos4.o: config.h vm-limit.o: $(LISP_H) lisp-disunion.h lisp-union.h lrecord.h mem-limits.h symeval.h symsinit.h -widget.o: $(LISP_H) buffer.h bufslots.h insdel.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h -window.o: $(LISP_H) buffer.h bufslots.h commands.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h +widget.o: $(LISP_H) buffer.h bufslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h symeval.h symsinit.h +window.o: $(LISP_H) buffer.h bufslots.h conslots.h console.h device.h faces.h frame.h frameslots.h glyphs.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects.h redisplay.h scrollbar.h specifier.h symeval.h symsinit.h toolbar.h window.h winslots.h xgccache.o: $(LISP_H) hash.h lisp-disunion.h lisp-union.h lrecord.h symeval.h symsinit.h xgccache.h xmu.o: config.h xselect.o: $(LISP_H) buffer.h bufslots.h conslots.h console-x.h console.h device.h frame.h frameslots.h lisp-disunion.h lisp-union.h lrecord.h mule-charset.h objects-x.h objects.h opaque.h scrollbar.h specifier.h symeval.h symsinit.h systime.h toolbar.h xintrinsic.h diff -r 76b7d63099ad -r 8626e4521993 src/device-msw.c --- a/src/device-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/device-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -159,7 +159,7 @@ static void mswindows_finish_init_device (struct device *d, Lisp_Object props) { - /* Initialise DDE management library and our related globals. We execute a + /* Initialize DDE management library and our related globals. We execute a * dde Open("file") by simulating a drop, so this depends on dnd support. */ #ifdef HAVE_DRAGNDROP mswindows_dde_mlid = 0; diff -r 76b7d63099ad -r 8626e4521993 src/device-x.c --- a/src/device-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/device-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -39,6 +39,7 @@ #include "objects-x.h" #include "buffer.h" +#include "elhash.h" #include "events.h" #include "faces.h" #include "frame.h" @@ -328,8 +329,6 @@ CONST char *app_class; CONST char *app_name; CONST char *disp_name; - Arg xargs[6]; - Cardinal numargs; Visual *visual = NULL; int depth = 8; /* shut up the compiler */ Colormap cmap; @@ -387,7 +386,7 @@ XtNumber (emacs_options), &argc, argv); speed_up_interrupts (); - screen = DefaultScreen(dpy); + screen = DefaultScreen (dpy); if (NILP (Vdefault_x_device)) Vdefault_x_device = device; @@ -400,7 +399,7 @@ does not override resources defined elsewhere */ CONST char *data_dir; char *path; - XrmDatabase db = XtDatabase (dpy); /* ### XtScreenDatabase(dpy) ? */ + XrmDatabase db = XtDatabase (dpy); /* #### XtScreenDatabase(dpy) ? */ CONST char *locale = XrmLocaleOfDatabase (db); if (STRINGP (Vx_app_defaults_directory) && @@ -434,9 +433,8 @@ XtGetApplicationNameAndClass (dpy, (char **) &app_name, (char **) &app_class); /* search for a matching visual if requested by the user, or setup the display default */ - numargs = 0; { - char *buf1 = (char *)alloca (strlen (app_name) + 17); + char *buf1 = (char *)alloca (strlen (app_name) + 17); char *buf2 = (char *)alloca (strlen (app_class) + 17); char *type; XrmValue value; @@ -445,85 +443,98 @@ 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_VISUAL (d) = visual; DEVICE_X_COLORMAP (d) = cmap; - DEVICE_X_DEPTH (d) = depth; - + DEVICE_X_DEPTH (d) = depth; validify_resource_component ((char *) XSTRING_DATA (DEVICE_NAME (d)), XSTRING_LENGTH (DEVICE_NAME (d))); - app_shell = XtAppCreateShell (NULL, app_class, - applicationShellWidgetClass, - dpy, xargs, numargs); + + { + Arg al[3]; + XtSetArg (al[0], XtNvisual, visual); + XtSetArg (al[1], XtNdepth, depth); + XtSetArg (al[2], XtNcolormap, cmap); + + app_shell = XtAppCreateShell (NULL, app_class, + applicationShellWidgetClass, + dpy, al, countof (al)); + } DEVICE_XT_APP_SHELL (d) = app_shell; + #ifdef HAVE_XIM XIM_init_device(d); #endif /* HAVE_XIM */ @@ -531,19 +542,16 @@ /* Realize the app_shell so that its window exists for GC creation purposes, and set it to the size of the root window for child placement purposes */ { - Screen *scrn = ScreenOfDisplay(dpy, screen); - int screen_width, screen_height; - screen_width = WidthOfScreen(scrn); - screen_height = HeightOfScreen(scrn); - numargs = 0; - XtSetArg (xargs[numargs], XtNmappedWhenManaged, False); numargs++; - XtSetArg (xargs[numargs], XtNx, 0); numargs++; - XtSetArg (xargs[numargs], XtNy, 0); numargs++; - XtSetArg (xargs[numargs], XtNwidth, screen_width); numargs++; - XtSetArg (xargs[numargs], XtNheight, screen_height); numargs++; - XtSetValues (app_shell, xargs, numargs); + Arg al[5]; + XtSetArg (al[0], XtNmappedWhenManaged, False); + XtSetArg (al[1], XtNx, 0); + XtSetArg (al[2], XtNy, 0); + XtSetArg (al[3], XtNwidth, WidthOfScreen (ScreenOfDisplay (dpy, screen))); + XtSetArg (al[4], XtNheight, HeightOfScreen (ScreenOfDisplay (dpy, screen))); + XtSetValues (app_shell, al, countof (al)); XtRealizeWidget (app_shell); } + #ifdef HAVE_SESSION { int new_argc; @@ -593,8 +601,8 @@ static void x_mark_device (struct device *d, void (*markobj) (Lisp_Object)) { - ((markobj) (DEVICE_X_WM_COMMAND_FRAME (d))); - ((markobj) (DEVICE_X_DATA (d)->x_keysym_map_hashtable)); + markobj (DEVICE_X_WM_COMMAND_FRAME (d)); + markobj (DEVICE_X_DATA (d)->x_keysym_map_hash_table); } @@ -637,6 +645,12 @@ if (DEVICE_X_DATA (d)->x_keysym_map) XFree ((char *) DEVICE_X_DATA (d)->x_keysym_map); + if (DEVICE_XT_APP_SHELL (d)) + { + XtDestroyWidget (DEVICE_XT_APP_SHELL (d)); + DEVICE_XT_APP_SHELL (d) = NULL; + } + XtCloseDisplay (display); DEVICE_X_DISPLAY (d) = 0; #ifdef FREE_CHECKING @@ -915,7 +929,7 @@ DEVICE_X_BEING_DELETED (d) = 1; Fthrow (Qtop_level, Qnil); - RETURN_NOT_REACHED (0); + return 0; /* not reached */ } DEFUN ("x-debug-mode", Fx_debug_mode, 1, 2, 0, /* @@ -1448,8 +1462,8 @@ return XStringToKeysym (keysym_ext) ? Qt : Qnil; } -DEFUN ("x-keysym-hashtable", Fx_keysym_hashtable, 0, 1, 0, /* -Return a hashtable which contains a hash key for all keysyms which +DEFUN ("x-keysym-hash-table", Fx_keysym_hash_table, 0, 1, 0, /* +Return a hash table which contains a hash key for all keysyms which name keys on the keyboard. See `x-keysym-on-keyboard-p'. */ (device)) @@ -1458,7 +1472,7 @@ if (!DEVICE_X_P (d)) signal_simple_error ("Not an X device", device); - return DEVICE_X_DATA (d)->x_keysym_map_hashtable; + return DEVICE_X_DATA (d)->x_keysym_map_hash_table; } DEFUN ("x-keysym-on-keyboard-sans-modifiers-p", Fx_keysym_on_keyboard_sans_modifiers_p, @@ -1480,7 +1494,7 @@ signal_simple_error ("Not an X device", device); return (EQ (Qsans_modifiers, - Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASHTABLE (d), Qnil)) ? + Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASH_TABLE (d), Qnil)) ? Qt : Qnil); } @@ -1502,7 +1516,7 @@ if (!DEVICE_X_P (d)) signal_simple_error ("Not an X device", device); - return (NILP (Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASHTABLE (d), Qnil)) ? + return (NILP (Fgethash (keysym, DEVICE_X_KEYSYM_MAP_HASH_TABLE (d), Qnil)) ? Qnil : Qt); } @@ -1654,7 +1668,7 @@ DEFSUBR (Fx_server_vendor); DEFSUBR (Fx_server_version); DEFSUBR (Fx_valid_keysym_name_p); - DEFSUBR (Fx_keysym_hashtable); + DEFSUBR (Fx_keysym_hash_table); DEFSUBR (Fx_keysym_on_keyboard_p); DEFSUBR (Fx_keysym_on_keyboard_sans_modifiers_p); diff -r 76b7d63099ad -r 8626e4521993 src/device.c --- a/src/device.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/device.c Mon Aug 13 11:07:10 2007 +0200 @@ -37,11 +37,14 @@ #include "frame.h" #include "keymap.h" #include "redisplay.h" -#include "scrollbar.h" #include "specifier.h" #include "sysdep.h" #include "window.h" +#ifdef HAVE_SCROLLBARS +#include "scrollbar.h" +#endif + #include "syssignal.h" /* Vdefault_device is the firstly-created non-stream device that's still @@ -82,29 +85,29 @@ { 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->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->color_instance_cache); + markobj (d->font_instance_cache); #ifdef MULE - ((markobj) (d->charset_font_cache)); + markobj (d->charset_font_cache); #endif - ((markobj) (d->image_instance_cache)); + markobj (d->image_instance_cache); if (d->devmeths) { - ((markobj) (d->devmeths->symbol)); + markobj (d->devmeths->symbol); MAYBE_DEVMETH (d, mark_device, (d, markobj)); } @@ -177,7 +180,7 @@ d->connection = Qnil; d->canon_connection = Qnil; d->frame_list = Qnil; - d->_selected_frame = Qnil; + d->selected_frame = Qnil; d->frame_with_focus_real = Qnil; d->frame_with_focus_for_hooks = Qnil; d->frame_that_ought_to_have_focus = Qnil; @@ -189,22 +192,22 @@ d->infd = d->outfd = -1; /* #### is 20 reasonable? */ - d->color_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQUAL); - d->font_instance_cache = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQUAL); + d->color_instance_cache = + make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL); + d->font_instance_cache = + make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQUAL); #ifdef MULE /* Note that the following table is bi-level. */ - d->charset_font_cache = make_lisp_hashtable (20, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + d->charset_font_cache = + make_lisp_hash_table (20, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); #endif /* Note that the image instance cache is actually bi-level. See device.h. We use a low number here because most of the - time there aren't very many diferent masks that will be used. + time there aren't very many different masks that will be used. */ - d->image_instance_cache = make_lisp_hashtable (5, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + d->image_instance_cache = + make_lisp_hash_table (5, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); UNGCPRO; return d; @@ -216,7 +219,7 @@ if (NILP (device)) device = Fselected_device (Qnil); /* quietly accept frames for the device arg */ - if (FRAMEP (device)) + else if (FRAMEP (device)) device = FRAME_DEVICE (decode_frame (device)); CHECK_LIVE_DEVICE (device); return XDEVICE (device); @@ -287,7 +290,7 @@ { if (!NILP (frame) && !FRAME_MINIBUF_ONLY_P (XFRAME (frame))) set_console_last_nonminibuf_frame (XCONSOLE (DEVICE_CONSOLE (d)), frame); - d->_selected_frame = frame; + d->selected_frame = frame; } DEFUN ("set-device-selected-frame", Fset_device_selected_frame, 2, 2, 0, /* @@ -914,7 +917,7 @@ METRIC must be a symbol specifying requested metric. Note that the metrics returned are these provided by the system internally, not read from resources, -so obtained from the most internal level. +so obtained from the most internal level. If a metric is not provided by the system, then DEFAULT is returned. @@ -923,14 +926,14 @@ Metrics, by group, are: COLORS. Colors are returned as valid color instantiators. No other assumption -on the returned valie should be made (i.e. it can be a string on one system but +on the returned value should be made (i.e. it can be a string on one system but a color instance on another). For colors, returned value is a cons of foreground and background colors. Note that if the system provides only one color of the pair, the second one may be nil. color-default Standard window text foreground and background. -color-select Selection highligh text and backgroun colors. -color-balloon Ballon popup text and background colors. +color-select Selection highlight text and background colors. +color-balloon Balloon popup text and background colors. color-3d-face 3-D object (button, modeline) text and surface colors. color-3d-light Fore and back colors for 3-D edges facing light source. color-3d-dark Fore and back colors for 3-D edges facing away from @@ -954,7 +957,7 @@ GEOMETRY. These metrics are returned as conses of (X . Y). As with colors, either car or cdr of the cons may be nil if the system does not provide one -of corresponding dimensions. +of the corresponding dimensions. size-cursor Mouse cursor size. size-scrollbar Scrollbars (WIDTH . HEIGHT) @@ -971,14 +974,14 @@ windows. size-device-mm Device screen size in millimeters. device-dpi Device resolution, in dots per inch. -num-bit-planes Integer, number of deivce bit planes. +num-bit-planes Integer, number of device bit planes. num-color-cells Integer, number of device color cells. FEATURES. This group reports various device features. If a feature is present, integer 1 (one) is returned, if it is not present, then integer 0 (zero) is returned. If the system is unaware of the feature, then DEFAULT is returned. - + mouse-buttons Integer, number of mouse buttons, or zero if no mouse. swap-buttons Non-zero if left and right mouse buttons are swapped. show-sounds User preference for visual over audible bell. diff -r 76b7d63099ad -r 8626e4521993 src/device.h --- a/src/device.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/device.h Mon Aug 13 11:07:10 2007 +0200 @@ -100,7 +100,7 @@ frames on this device have the window-system focus), but selected_frame will never be nil if there are any frames on the device. */ - Lisp_Object _selected_frame; + Lisp_Object selected_frame; /* Frame that currently contains the window-manager focus, or none. Note that we've split frame_with_focus into two variables. frame_with_focus_real is the value we use most of the time, @@ -308,7 +308,7 @@ #define DEVICE_NAME(d) ((d)->name) #define DEVICE_CLASS(d) ((d)->device_class) /* Catch people attempting to set this. */ -#define DEVICE_SELECTED_FRAME(d) NON_LVALUE ((d)->_selected_frame) +#define DEVICE_SELECTED_FRAME(d) NON_LVALUE ((d)->selected_frame) #define DEVICE_FRAME_WITH_FOCUS_REAL(d) ((d)->frame_with_focus_real) #define DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS(d) ((d)->frame_with_focus_for_hooks) #define DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS(d) \ @@ -331,11 +331,11 @@ #define INVALIDATE_DEVICE_PIXEL_TO_GLYPH_CACHE(d) \ ((void) ((d)->pixel_to_glyph_cache.valid = 0)) -#define INVALIDATE_PIXEL_TO_GLYPH_CACHE do { \ - Lisp_Object _devcons_, _concons_; \ - DEVICE_LOOP_NO_BREAK (_devcons_, _concons_) \ - INVALIDATE_DEVICE_PIXEL_TO_GLYPH_CACHE (XDEVICE (XCAR (_devcons_)));\ - } while (0) +#define INVALIDATE_PIXEL_TO_GLYPH_CACHE do { \ + Lisp_Object IPTGC_devcons, IPTGC_concons; \ + DEVICE_LOOP_NO_BREAK (IPTGC_devcons, IPTGC_concons) \ + INVALIDATE_DEVICE_PIXEL_TO_GLYPH_CACHE (XDEVICE (XCAR (IPTGC_devcons))); \ +} while (0) #define MARK_DEVICE_FACES_CHANGED(d) \ ((void) (faces_changed = (d)->faces_changed = 1)) diff -r 76b7d63099ad -r 8626e4521993 src/dgif_lib.c --- a/src/dgif_lib.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dgif_lib.c Mon Aug 13 11:07:10 2007 +0200 @@ -112,7 +112,7 @@ Buf[GIF_STAMP_LEN] = 0; if (strncmp(GIF_STAMP, (const char *) Buf, GIF_VERSION_POS) != 0) { GifInternError(GifFile, D_GIF_ERR_NOT_GIF_FILE); - } + } DGifGetScreenDesc(GifFile); } @@ -249,7 +249,7 @@ MakeMapObject (GifFile->Image.ColorMap->ColorCount, GifFile->Image.ColorMap->Colors); } - sp->RasterBits = (GifPixelType *)NULL; + sp->RasterBits = NULL; sp->ExtensionBlockCount = 0; sp->ExtensionBlocks = (ExtensionBlock *)NULL; } @@ -745,7 +745,7 @@ ImageSize = sp->ImageDesc.Width * sp->ImageDesc.Height; sp->RasterBits - = (GifPixelType*) malloc(ImageSize * sizeof(GifPixelType)); + = (GifPixelType*) malloc (ImageSize * sizeof(GifPixelType)); DGifGetLine(GifFile, sp->RasterBits, ImageSize); break; @@ -856,7 +856,7 @@ CopyFrom->ImageDesc.ColorMap->Colors); /* next, the raster */ - sp->RasterBits = (GifPixelType*)malloc(sizeof(GifPixelType) + sp->RasterBits = (GifPixelType *) malloc(sizeof(GifPixelType) * CopyFrom->ImageDesc.Height * CopyFrom->ImageDesc.Width); memcpy(sp->RasterBits, @@ -911,7 +911,7 @@ * Miscellaneous utility functions * ******************************************************************************/ -int BitSize(int n) +static int BitSize(int n) /* return smallest bitfield size n will fit in */ { register int i; diff -r 76b7d63099ad -r 8626e4521993 src/dialog-msw.c --- a/src/dialog-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dialog-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -20,7 +20,7 @@ /* Synched up with: Not in FSF. */ -/* Autorship: +/* Author: Initially written by kkm, May 1998 */ @@ -46,9 +46,9 @@ Button metrics -------------- All buttons have height of 15 DLU. The minimum width for a button is 32 DLU, - but it can be expanded to accomodate its text, so the width is calculated as + but it can be expanded to accommodate its text, so the width is calculated as 8 DLU per button plus 4 DLU per character. - max (32, 6 * text_lenght). The factor of six is rather empirical, but it + max (32, 6 * text_length). The factor of six is rather empirical, but it works better than 8 which comes from the definition of a DLU. Buttons are spaced with 6 DLU gap. Minimum distance from the button to the left or right dialog edges is 6 DLU, and the distance between the dialog bottom edge and @@ -65,11 +65,11 @@ /* Text field metrics ------------------ - Text ditance from lwft and right edges is the same as for buttons, and the + Text distance from left and right edges is the same as for buttons, and the top margin is 11 DLU. The static control has height of 2 DLU per control plus 8 DLU per each line of text. Distance between the bottom edge of the control and the button row is 15 DLU. Minimum width of the static control - is 100 DLU, thus giving minmium dialog wight of 112 DLU. Maximum width is + is 100 DLU, thus giving minimum dialog weight of 112 DLU. Maximum width is 300 DLU, and, if the text is wider than that, the text is wrapped on the next line. Each character in the text is considered 4 DLU wide. */ @@ -98,13 +98,13 @@ Next, the width of the static field is determined. First, if all lines of text fit into max (WBR, X_MAX_TEXT), the width of the control is the same as the width of the longest line. - Sencond, if all lines of text are narrower than X_MIN_TEXT, then width of + Second, if all lines of text are narrower than X_MIN_TEXT, then width of the control is set to X_MIN_TEXT. Otherwise, width is set to max(WBR, X_AVE_TEXT). In this case, line wrapping will happen. - If width of the text contol is larger than that of the button row, then the - latter is centered accross the dialog, by giving it extra edge + If width of the text control is larger than that of the button row, then the + latter is centered across the dialog, by giving it extra edge margins. Otherwise, minimal margins are given to the button row. */ diff -r 76b7d63099ad -r 8626e4521993 src/dialog-x.c --- a/src/dialog-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dialog-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -25,9 +25,7 @@ #include "lisp.h" #include "console-x.h" -#include "EmacsManager.h" #include "EmacsFrame.h" -#include "EmacsShell.h" #include "gui-x.h" #include "buffer.h" diff -r 76b7d63099ad -r 8626e4521993 src/dired.c --- a/src/dired.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dired.c Mon Aug 13 11:07:10 2007 +0200 @@ -116,7 +116,7 @@ which might compile a new regexp until we're done with the loop! */ /* Do this opendir after anything which might signal an error. - NOTE: the above comment is old; previosly, there was no + NOTE: the above comment is old; previously, there was no unwind-protection in case of error, but now there is. */ d = opendir ((char *) XSTRING_DATA (dirname)); if (!d) @@ -128,7 +128,6 @@ while (1) { DIRENTRY *dp = readdir (d); - Lisp_Object name; int len; if (!dp) @@ -179,22 +178,22 @@ continue; } - if (!NILP (full)) - name = concat2 (dirname, make_ext_string ((Bufbyte *)dp->d_name, - len, FORMAT_FILENAME)); - else - name = make_ext_string ((Bufbyte *)dp->d_name, - len, FORMAT_FILENAME); + { + Lisp_Object name = + make_ext_string ((Bufbyte *)dp->d_name, len, FORMAT_FILENAME); + if (!NILP (full)) + name = concat2 (dirname, name); - list = Fcons (name, list); + list = Fcons (name, list); + } } } unbind_to (speccount, Qnil); /* This will close the dir */ - if (!NILP (nosort)) - RETURN_UNGCPRO (list); - else - RETURN_UNGCPRO (Fsort (Fnreverse (list), Qstring_lessp)); + if (NILP (nosort)) + list = Fsort (Fnreverse (list), Qstring_lessp); + + RETURN_UNGCPRO (list); } static Lisp_Object file_name_completion (Lisp_Object file, @@ -691,14 +690,10 @@ for (i = 0; i < user_cache_len; i++) { - Bytecount len; + Bufbyte *d_name = (Bufbyte *) user_cache[i]; + Bytecount len = strlen ((char *) d_name); /* scmp() works in chars, not bytes, so we have to compute this: */ - Charcount cclen; - Bufbyte *d_name; - - d_name = (Bufbyte *) user_cache[i]; - len = strlen (d_name); - cclen = bytecount_to_charcount (d_name, len); + Charcount cclen = bytecount_to_charcount (d_name, len); QUIT; @@ -784,8 +779,8 @@ make_directory_hash_table (CONST char *path) { DIR *d; - Lisp_Object hash = make_lisp_hashtable (100, HASHTABLE_NONWEAK, - HASHTABLE_EQUAL); + Lisp_Object hash = + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); if ((d = opendir (path))) { DIRENTRY *dp; diff -r 76b7d63099ad -r 8626e4521993 src/dll.c --- a/src/dll.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dll.c Mon Aug 13 11:07:10 2007 +0200 @@ -43,7 +43,6 @@ #include "lisp.h" #include "buffer.h" #include "sysdll.h" -#include DEFUN ("dll-open", Fdll_open, 1, 1, "FShared object: ", /* Load LIBRARY as a shared object file. diff -r 76b7d63099ad -r 8626e4521993 src/doc.c --- a/src/doc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/doc.c Mon Aug 13 11:07:10 2007 +0200 @@ -284,10 +284,10 @@ else if (COMPILED_FUNCTIONP (fun)) { Lisp_Object tem; - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - if (! (b->flags.documentationp)) + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + if (! (f->flags.documentationp)) return Qnil; - tem = compiled_function_documentation (b); + tem = compiled_function_documentation (f); if (STRINGP (tem)) doc = tem; else if (NATNUMP (tem) || CONSP (tem)) @@ -338,7 +338,7 @@ #ifdef I18N3 Lisp_Object domain = Qnil; if (COMPILED_FUNCTIONP (fun)) - domain = Fcompiled_function_domain (fun); + domain = compiled_function_domain (XCOMPILED_FUNCTION (fun)); if (NILP (domain)) doc = Fgettext (doc); else @@ -550,7 +550,7 @@ { weird_doc (sym, GETTEXT ("!CONSP(tem)"), GETTEXT ("function"), pos); - goto cont; + goto cont; } else { @@ -573,7 +573,7 @@ { /* Compiled-Function objects sometimes have slots for it. */ - struct Lisp_Compiled_Function *b = + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); /* This compiled-function object must have a @@ -583,7 +583,7 @@ have any doc, which is a legal if slightly bogus situation, so don't blow up. */ - if (! (b->flags.documentationp)) + if (! (f->flags.documentationp)) { weird_doc (sym, GETTEXT ("no doc slot"), GETTEXT ("bytecode"), pos); @@ -592,7 +592,7 @@ else { Lisp_Object old = - compiled_function_documentation (b); + compiled_function_documentation (f); if (!ZEROP (old)) { weird_doc (sym, GETTEXT ("duplicate"), @@ -603,7 +603,7 @@ if (!INTP (old)) goto weird; } - set_compiled_function_documentation (b, offset); + set_compiled_function_documentation (f, offset); } } else @@ -684,12 +684,12 @@ } else if (COMPILED_FUNCTIONP (fun)) { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (fun); - if (! (b->flags.documentationp)) + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun); + if (! (f->flags.documentationp)) doc = -1; else { - Lisp_Object tem = compiled_function_documentation (b); + Lisp_Object tem = compiled_function_documentation (f); if (INTP (tem)) doc = XINT (tem); } diff -r 76b7d63099ad -r 8626e4521993 src/doprnt.c --- a/src/doprnt.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/doprnt.c Mon Aug 13 11:07:10 2007 +0200 @@ -576,7 +576,7 @@ { Lisp_Object obj = largs[spec->argnum - 1]; if (CHARP (obj)) - CHECK_INT_COERCE_CHAR (obj); + obj = make_int (XCHAR (obj)); if (!INT_OR_FLOATP (obj)) { error ("format specifier %%%c doesn't match argument type", diff -r 76b7d63099ad -r 8626e4521993 src/dynarr.c --- a/src/dynarr.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/dynarr.c Mon Aug 13 11:07:10 2007 +0200 @@ -44,7 +44,7 @@ This is a container object. Declare a dynamic array of a specific type as follows: -typdef struct +typedef struct { Dynarr_declare (mytype); } mytype_dynarr; @@ -72,7 +72,7 @@ The elements should be contiguous in memory, starting at BASE. Dynarr_insert_many(d, base, len, start) - Insert LEN elements to the dynamic arrary starting at position + Insert LEN elements to the dynamic array starting at position START. The elements should be contiguous in memory, starting at BASE. int Dynarr_length(d) diff -r 76b7d63099ad -r 8626e4521993 src/ecrt0.c --- a/src/ecrt0.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/ecrt0.c Mon Aug 13 11:07:10 2007 +0200 @@ -22,7 +22,7 @@ /* The standard Vax 4.2 Unix crt0.c cannot be used for Emacs - because it makes `envron' an initialized variable. + because it makes `environ' an initialized variable. It is easiest to have a special crt0.c on all machines though I don't know whether other machines actually need it. */ diff -r 76b7d63099ad -r 8626e4521993 src/editfns.c --- a/src/editfns.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/editfns.c Mon Aug 13 11:07:10 2007 +0200 @@ -370,7 +370,7 @@ and cleaner never to alter the window/buffer connections. */ /* I'm certain some code somewhere depends on this behavior. --jwz */ /* Even if it did, it certainly doesn't matter anymore, because - this has been the behaviour for countless XEmacs releases + this has been the behavior for countless XEmacs releases now. --hniksic */ if (visible && (current_buffer != XBUFFER (XWINDOW (selected_window)->buffer))) @@ -549,7 +549,6 @@ (buffer)) { struct buffer *b = decode_buffer (buffer, 1); - return beginning_of_line_p (b, BUF_PT (b)) ? Qt : Qnil; } @@ -668,7 +667,7 @@ user_login_name (int *uid) { struct passwd *pw = NULL; - + /* uid == NULL to return name of this user */ if (uid != NULL) { @@ -758,7 +757,7 @@ Lisp_Object user_name; struct passwd *pw = NULL; Lisp_Object tem; - char *p, *q; + const char *p, *q; if (NILP (user) && STRINGP (Vuser_full_name)) return Vuser_full_name; @@ -833,7 +832,7 @@ { #if defined(WINDOWSNT) && !defined(__CYGWIN32__) char *homedrive, *homepath; - + if ((homedrive = getenv("HOMEDRIVE")) != NULL && (homepath = getenv("HOMEPATH")) != NULL) { @@ -1063,14 +1062,14 @@ BUG: If the charset used by the current locale is not ISO 8859-1, the characters appearing in the day and month names may be incorrect. */ - (format_string, _time)) + (format_string, time_)) { time_t value; size_t size; CHECK_STRING (format_string); - if (! lisp_to_time (_time, &value)) + if (! lisp_to_time (time_, &value)) error ("Invalid time specification"); /* This is probably enough. */ @@ -1115,13 +1114,13 @@ error ("Invalid time specification"); decoded_time = localtime (&time_spec); - XSETINT (list_args[0], decoded_time->tm_sec); - XSETINT (list_args[1], decoded_time->tm_min); - XSETINT (list_args[2], decoded_time->tm_hour); - XSETINT (list_args[3], decoded_time->tm_mday); - XSETINT (list_args[4], decoded_time->tm_mon + 1); - XSETINT (list_args[5], decoded_time->tm_year + 1900); - XSETINT (list_args[6], decoded_time->tm_wday); + list_args[0] = make_int (decoded_time->tm_sec); + list_args[1] = make_int (decoded_time->tm_min); + list_args[2] = make_int (decoded_time->tm_hour); + list_args[3] = make_int (decoded_time->tm_mday); + list_args[4] = make_int (decoded_time->tm_mon + 1); + list_args[5] = make_int (decoded_time->tm_year + 1900); + list_args[6] = make_int (decoded_time->tm_wday); list_args[7] = (decoded_time->tm_isdst)? Qt : Qnil; /* Make a copy, in case gmtime modifies the struct. */ @@ -1130,7 +1129,7 @@ if (decoded_time == 0) list_args[8] = Qnil; else - XSETINT (list_args[8], difftm (&save_tm, decoded_time)); + list_args[8] = make_int (difftm (&save_tm, decoded_time)); return Flist (9, list_args); } @@ -1156,7 +1155,7 @@ */ (int nargs, Lisp_Object *args)) { - time_t _time; + time_t the_time; struct tm tm; Lisp_Object zone = (nargs > 6) ? args[nargs - 1] : Qnil; @@ -1172,7 +1171,7 @@ if (CONSP (zone)) zone = XCAR (zone); if (NILP (zone)) - _time = mktime (&tm); + the_time = mktime (&tm); else { char tzbuf[100]; @@ -1195,7 +1194,7 @@ value doesn't suffice, since that would mishandle leap seconds. */ set_time_zone_rule (tzstring); - _time = mktime (&tm); + the_time = mktime (&tm); /* Restore TZ to previous value. */ newenv = environ; @@ -1206,10 +1205,10 @@ #endif } - if (_time == (time_t) -1) + if (the_time == (time_t) -1) error ("Specified time is not representable"); - return wasteful_word_to_lisp (_time); + return wasteful_word_to_lisp (the_time); } DEFUN ("current-time-string", Fcurrent_time_string, 0, 1, 0, /* diff -r 76b7d63099ad -r 8626e4521993 src/elhash.c --- a/src/elhash.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/elhash.c Mon Aug 13 11:07:10 2007 +0200 @@ -1,4 +1,4 @@ -/* Lisp interface to hash tables. +/* Implementation of the hash table lisp object type. Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. Copyright (C) 1995, 1996 Ben Wing. Copyright (C) 1997 Free Software Foundation, Inc. @@ -11,7 +11,7 @@ later version. XEmacs is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +ANY WARRANTY; without even the implied warranty of MERCNTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. @@ -24,122 +24,237 @@ #include #include "lisp.h" -#include "hash.h" +#include "bytecode.h" #include "elhash.h" -#include "bytecode.h" -EXFUN (Fmake_weak_hashtable, 2); -EXFUN (Fmake_key_weak_hashtable, 2); -EXFUN (Fmake_value_weak_hashtable, 2); +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; -Lisp_Object Qhashtablep, Qhashtable; -Lisp_Object Qweak, Qkey_weak, Qvalue_weak, Qnon_weak; +typedef struct hentry +{ + Lisp_Object key; + Lisp_Object value; +} hentry; -#define LISP_OBJECTS_PER_HENTRY (sizeof (hentry) / sizeof (Lisp_Object))/* 2 */ - -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; -static Lisp_Object Vall_weak_hashtables; +#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 -mark_hashtable (Lisp_Object obj, void (*markobj) (Lisp_Object)) +#if ERROR_CHECK_HASH_TABLE +static void +check_hash_table_invariants (Lisp_Hash_Table *ht) { - struct hashtable *table = XHASHTABLE (obj); + assert (ht->count < ht->size); + assert (ht->count <= ht->rehash_count); + assert (ht->rehash_count < ht->size); + assert ((double) ht->count * ht->rehash_threshold - 1 <= (double) ht->rehash_count); + assert (HENTRY_CLEAR_P (ht->hentries + ht->size)); +} +#else +#define check_hash_table_invariants(ht) +#endif + +/* We use linear probing instead of double hashing, despite its lack + of blessing by Knuth and company, because, as a result of the + increasing discrepancy between CPU speeds and memory speeds, cache + behavior is becoming increasingly important, e.g: + + For a trivial loop, the penalty for non-sequential access of an array is: + - a factor of 3-4 on Pentium Pro 200 Mhz + - a factor of 10 on Ultrasparc 300 Mhz */ - if (table->type != HASHTABLE_NONWEAK) +/* Return a suitable size for a hash table, with at least SIZE slots. */ +static size_t +hash_table_size (size_t requested_size) +{ + /* Return some prime near, but greater than or equal to, SIZE. + Decades from the time of writing, someone will have a system large + enough that the list below will be too short... */ + static CONST size_t primes [] = + { + 19, 29, 41, 59, 79, 107, 149, 197, 263, 347, 457, 599, 787, 1031, + 1361, 1777, 2333, 3037, 3967, 5167, 6719, 8737, 11369, 14783, + 19219, 24989, 32491, 42257, 54941, 71429, 92861, 120721, 156941, + 204047, 265271, 344857, 448321, 582821, 757693, 985003, 1280519, + 1664681, 2164111, 2813353, 3657361, 4754591, 6180989, 8035301, + 10445899, 13579681, 17653589, 22949669, 29834603, 38784989, + 50420551, 65546729, 85210757, 110774011, 144006217, 187208107, + 243370577, 316381771, 411296309, 534685237, 695090819, 903618083, + 1174703521, 1527114613, 1985248999, 2580823717UL, 3355070839UL + }; + /* We've heard of binary search. */ + int low, high; + for (low = 0, high = countof (primes) - 1; high - low > 1;) { - /* If the table is weak, we don't want to mark the keys and values - (we scan over them after everything else has been marked, - and mark or remove them as necessary). Note that we will mark - the table->harray itself at the same time; it's hard to mark - that here without also marking its contents. */ - return Qnil; + /* Loop Invariant: size < primes [high] */ + int mid = (low + high) / 2; + if (primes [mid] < requested_size) + low = mid; + else + high = mid; } - ((markobj) (table->zero_entry)); - return table->harray; + return primes [high]; } + -/* Equality of hashtables. Two hashtables are equal when they are of - the same type and test function, they have the same number of - elements, and for each key in hashtable, the values are `equal'. +#if 0 /* I don't think these are needed any more. + If using the general lisp_object_equal_*() functions + causes efficiency problems, these can be resurrected. --ben */ +/* equality and hash functions for Lisp strings */ +int +lisp_string_equal (Lisp_Object str1, Lisp_Object str2) +{ + /* This is wrong anyway. You can't use strcmp() on Lisp strings, + because they can contain zero characters. */ + return !strcmp ((char *) XSTRING_DATA (str1), (char *) XSTRING_DATA (str2)); +} - This is similar to Common Lisp `equalp' of hashtables, with the - difference that CL requires the keys to be compared with the test - function, which we don't do. Doing that would require consing, and - consing is bad idea in `equal'. Anyway, our method should provide - the same result -- if the keys are not equal according to test - function, then Fgethash() in hashtable_equal_mapper() will fail. */ -struct hashtable_equal_closure +static hashcode_t +lisp_string_hash (Lisp_Object obj) { - int depth; - int equal; - Lisp_Object other_table; -}; + return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str)); +} + +#endif /* 0 */ static int -hashtable_equal_mapper (CONST void *key, void *contents, void *arg) +lisp_object_eql_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; + return EQ (obj1, obj2) || (FLOATP (obj1) && internal_equal (obj1, obj2, 0)); +} - 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)) - { - /* Give up. */ - closure->equal = 0; - return 1; - } - return 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 (Lisp_Object t1, Lisp_Object t2, int depth) +lisp_object_equal_equal (Lisp_Object obj1, Lisp_Object obj2) +{ + return internal_equal (obj1, obj2, 0); +} + +static hashcode_t +lisp_object_equal_hash (Lisp_Object obj) { - struct hashtable_equal_closure closure; - struct hashtable *table1 = XHASHTABLE (t1); - struct hashtable *table2 = XHASHTABLE (t2); + return internal_hash (obj, 0); +} + + +static Lisp_Object +mark_hash_table (Lisp_Object obj, void (*markobj) (Lisp_Object)) +{ + Lisp_Hash_Table *ht = XHASH_TABLE (obj); + + /* If the hash table is weak, we don't want to mark the keys and + values (we scan over them after everything else has been marked, + and mark or remove them as necessary). */ + if (ht->type == HASH_TABLE_NON_WEAK) + { + hentry *e, *sentinel; - /* 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))*/ - ) + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + markobj (e->key); + markobj (e->value); + } + } + return Qnil; +} + +/* Equality of hash tables. Two hash tables are equal when they are of + the same type and test function, they have the same number of + elements, and for each key in the hash table, the values are `equal'. + + This is similar to Common Lisp `equalp' of hash tables, with the + difference that CL requires the keys to be compared with the test + function, which we don't do. Doing that would require consing, and + consing is a bad idea in `equal'. Anyway, our method should provide + the same result -- if the keys are not equal according to the test + function, then Fgethash() in hash_table_equal_mapper() will fail. */ +static int +hash_table_equal (Lisp_Object hash_table1, Lisp_Object hash_table2, int depth) +{ + Lisp_Hash_Table *ht1 = XHASH_TABLE (hash_table1); + Lisp_Hash_Table *ht2 = XHASH_TABLE (hash_table2); + hentry *e, *sentinel; + + if ((ht1->test_function != ht2->test_function) || + (ht1->type != ht2->type) || + (ht1->count != ht2->count)) return 0; - closure.depth = depth + 1; - closure.equal = 1; - closure.other_table = t2; - elisp_maphash (hashtable_equal_mapper, t1, &closure); - return closure.equal; + depth++; + + for (e = ht1->hentries, sentinel = e + ht1->size; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + /* Look up the key in the other hash table, and compare the values. */ + { + Lisp_Object value_in_other = Fgethash (e->key, hash_table2, Qunbound); + if (UNBOUNDP (value_in_other) || + !internal_equal (e->value, value_in_other, depth)) + return 0; /* Give up */ + } + + return 1; } -/* Printing hashtables. +/* Printing hash tables. This is non-trivial, because we use a readable structure-style - syntax for hashtables. This means that a typical hashtable will be + syntax for hash tables. This means that a typical hash table will be readably printed in the form of: - #s(hashtable size 2 data (key1 value1 key2 value2)) + #s(hash-table size 2 data (key1 value1 key2 value2)) The supported keywords are `type' (non-weak (or nil), weak, key-weak and value-weak), `test' (eql (or nil), eq or equal), @@ -148,210 +263,399 @@ If `print-readably' is non-nil, then a simpler syntax is used; for instance: - # + # The data is truncated to four pairs, and the rest is shown with `...'. This printer does not cons. */ -struct print_hashtable_data_closure -{ - EMACS_INT count; /* Used to implement truncation for - non-readable printing, as well as - to avoid the unnecessary space at - the beginning. */ - Lisp_Object printcharfun; -}; -static int -print_hashtable_data_mapper (CONST void *key, void *contents, void *arg) +/* Print the data of the hash table. This maps through a Lisp + hash table and prints key/value pairs using PRINTCHARFUN. */ +static void +print_hash_table_data (Lisp_Hash_Table *ht, Lisp_Object printcharfun) { - Lisp_Object keytem, valuetem; - struct print_hashtable_data_closure *closure = - (struct print_hashtable_data_closure *)arg; + int count = 0; + hentry *e, *sentinel; - if (closure->count < 4 || print_readably) - { - CVOID_TO_LISP (keytem, key); - CVOID_TO_LISP (valuetem, contents); + write_c_string (" data (", printcharfun); - if (closure->count) - write_c_string (" ", closure->printcharfun); + 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++; + } - print_internal (keytem, closure->printcharfun, 1); - write_c_string (" ", closure->printcharfun); - print_internal (valuetem, closure->printcharfun, 1); - } - ++closure->count; - return 0; + write_c_string (")", printcharfun); } -/* Print the data of the hashtable. This maps through a Lisp - hashtable and prints key/value pairs using PRINTCHARFUN. */ static void -print_hashtable_data (Lisp_Object hashtable, Lisp_Object printcharfun) +print_hash_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - struct print_hashtable_data_closure closure; - closure.count = 0; - closure.printcharfun = printcharfun; - - 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); - -static void -print_hashtable (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) -{ - struct hashtable *table = XHASHTABLE (obj); + Lisp_Hash_Table *ht = XHASH_TABLE (obj); char buf[128]; - write_c_string (print_readably ? "#s(hashtable" : "#type != HASHTABLE_NONWEAK) + + if (ht->type != HASH_TABLE_NON_WEAK) { sprintf (buf, " type %s", - (table->type == HASHTABLE_WEAK ? "weak" : - table->type == HASHTABLE_KEY_WEAK ? "key-weak" : - table->type == HASHTABLE_VALUE_WEAK ? "value-weak" : + (ht->type == HASH_TABLE_WEAK ? "weak" : + ht->type == HASH_TABLE_KEY_WEAK ? "key-weak" : + ht->type == HASH_TABLE_VALUE_WEAK ? "value-weak" : "you-d-better-not-see-this")); write_c_string (buf, printcharfun); } - /* These checks have a kludgy look to them, but they are safe. Due - to nature of hashing, you cannot use arbitrary test functions - anyway. */ - if (!table->test_function) + + /* These checks have a kludgy look to them, but they are safe. + Due to nature of hashing, you cannot use arbitrary + test functions anyway. */ + if (!ht->test_function) write_c_string (" test eq", printcharfun); - else if (table->test_function == lisp_object_equal_equal) + else if (ht->test_function == lisp_object_equal_equal) write_c_string (" test equal", printcharfun); - else if (table->test_function == lisp_object_eql_equal) + else if (ht->test_function == lisp_object_eql_equal) DO_NOTHING; else abort (); - if (table->fullness || !print_readably) + + if (ht->count || !print_readably) { if (print_readably) - sprintf (buf, " size %u", table->fullness); + sprintf (buf, " size %lu", (unsigned long) ht->count); else - sprintf (buf, " size %u/%ld", table->fullness, - XVECTOR_LENGTH (table->harray) / LISP_OBJECTS_PER_HENTRY); + sprintf (buf, " size %lu/%lu", + (unsigned long) ht->count, + (unsigned long) ht->size); write_c_string (buf, printcharfun); } - if (table->fullness) - print_hashtable_data (obj, printcharfun); + + if (ht->count) + print_hash_table_data (ht, printcharfun); + if (print_readably) write_c_string (")", printcharfun); else { - sprintf (buf, " 0x%x>", table->header.uid); + sprintf (buf, " 0x%x>", ht->header.uid); write_c_string (buf, printcharfun); } } -DEFINE_LRECORD_IMPLEMENTATION ("hashtable", hashtable, - mark_hashtable, print_hashtable, 0, - /* #### Implement hashtable_hash()! */ - hashtable_equal, 0, - struct hashtable); +static void +finalize_hash_table (void *header, int for_disksave) +{ + if (!for_disksave) + { + Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header; + + xfree (ht->hentries); + ht->hentries = 0; + } +} + +DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, + mark_hash_table, print_hash_table, + finalize_hash_table, + /* #### Implement hash_table_hash()! */ + hash_table_equal, 0, + Lisp_Hash_Table); + +static Lisp_Hash_Table * +xhash_table (Lisp_Object hash_table) +{ + if (!gc_in_progress) + CHECK_HASH_TABLE (hash_table); + check_hash_table_invariants (XHASH_TABLE (hash_table)); + return XHASH_TABLE (hash_table); +} + -/* Pretty reading of hashtables. +/************************************************************************/ +/* Creation of Hash Tables */ +/************************************************************************/ + +/* Creation of hash tables, without error-checking. */ +static double +hash_table_rehash_threshold (Lisp_Hash_Table *ht) +{ + return + ht->rehash_threshold > 0.0 ? ht->rehash_threshold : + ht->size > 4096 && !ht->test_function ? 0.7 : 0.6; +} + +static void +compute_hash_table_derived_values (Lisp_Hash_Table *ht) +{ + ht->rehash_count = (size_t) + ((double) ht->size * hash_table_rehash_threshold (ht)); + ht->golden = (size_t) + ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object))); +} + +Lisp_Object +make_general_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test, + double rehash_size, + double rehash_threshold) +{ + Lisp_Object hash_table; + Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, lrecord_hash_table); + + ht->type = type; + ht->rehash_size = rehash_size; + ht->rehash_threshold = rehash_threshold; + + switch (test) + { + case HASH_TABLE_EQ: + ht->test_function = 0; + ht->hash_function = 0; + break; + + case HASH_TABLE_EQL: + ht->test_function = lisp_object_eql_equal; + ht->hash_function = lisp_object_eql_hash; + break; + + case HASH_TABLE_EQUAL: + ht->test_function = lisp_object_equal_equal; + ht->hash_function = lisp_object_equal_hash; + break; + + default: + abort (); + } + + if (ht->rehash_size <= 0.0) + ht->rehash_size = HASH_TABLE_DEFAULT_REHASH_SIZE; + if (size < HASH_TABLE_MIN_SIZE) + size = HASH_TABLE_MIN_SIZE; + if (rehash_threshold < 0.0) + rehash_threshold = 0.75; + ht->size = + hash_table_size ((size_t) ((double) size / hash_table_rehash_threshold (ht)) + 1); + ht->count = 0; + compute_hash_table_derived_values (ht); + + /* We leave room for one never-occupied sentinel hentry at the end. */ + ht->hentries = xnew_array (hentry, ht->size + 1); + + { + hentry *e, *sentinel; + for (e = ht->hentries, sentinel = e + ht->size; e <= sentinel; e++) + CLEAR_HENTRY (e); + } + + XSETHASH_TABLE (hash_table, ht); + + if (type == HASH_TABLE_NON_WEAK) + ht->next_weak = Qunbound; + else + ht->next_weak = Vall_weak_hash_tables, Vall_weak_hash_tables = hash_table; + + return hash_table; +} + +Lisp_Object +make_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test) +{ + return make_general_lisp_hash_table (size, type, test, + HASH_TABLE_DEFAULT_REHASH_SIZE, -1.0); +} + +/* Pretty reading of hash tables. Here we use the existing structures mechanism (which is, unfortunately, pretty cumbersome) for validating and instantiating - the hashtables. The idea is that the side-effect of reading a - #s(hashtable PLIST) object is creation of a hashtable with desired - properties, and that the hashtable is returned. */ + the hash tables. The idea is that the side-effect of reading a + #s(hash-table PLIST) object is creation of a hash table with desired + properties, and that the hash table is returned. */ /* Validation functions: each keyword provides its own validation function. The errors should maybe be continuable, but it is unclear how this would cope with ERRB. */ static int -hashtable_type_validate (Lisp_Object keyword, Lisp_Object value, +hash_table_size_validate (Lisp_Object keyword, Lisp_Object value, + Error_behavior errb) +{ + if (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 +hash_table_type_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))) + 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 type", 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_test_validate (Lisp_Object keyword, Lisp_Object value, +hash_table_rehash_threshold_validate (Lisp_Object keyword, Lisp_Object value, + Error_behavior errb) +{ + if (!FLOATP (value)) + { + 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 +hash_table_data_validate (Lisp_Object keyword, Lisp_Object value, Error_behavior errb) { - if (!(NILP (value) - || EQ (value, Qeq) - || EQ (value, Qeql) - || EQ (value, Qequal))) + int len; + + GET_EXTERNAL_LIST_LENGTH (value, len); + + if (len & 1) { - maybe_signal_simple_error ("Invalid hashtable test", value, - Qhashtable, errb); + maybe_signal_simple_error + ("Hash table data must have alternating key/value pairs", + value, Qhash_table, errb); return 0; } return 1; } -static int -hashtable_size_validate (Lisp_Object keyword, Lisp_Object value, - Error_behavior errb) -{ - if (!NATNUMP (value)) - { - maybe_signal_error (Qwrong_type_argument, list2 (Qnatnump, value), - Qhashtable, errb); - return 0; - } - return 1; -} - -static int -hashtable_data_validate (Lisp_Object keyword, Lisp_Object value, - Error_behavior errb) -{ - int num = 0; - Lisp_Object tail; - - /* #### Doesn't respect ERRB! */ - EXTERNAL_LIST_LOOP (tail, value) - { - ++num; - QUIT; - } - if (num & 1) - { - maybe_signal_simple_error - ("Hashtable data must have alternating keyword/value pairs", value, - Qhashtable, errb); - return 0; - } - return 1; -} - -/* The actual instantiation of hashtable. This does practically no +/* The actual instantiation of a hash table. This does practically no error checking, because it relies on the fact that the paranoid functions above have error-checked everything to the last details. If this assumption is wrong, we will get a crash immediately (with error-checking compiled in), and we'll know if there is a bug in the structure mechanism. So there. */ static Lisp_Object -hashtable_instantiate (Lisp_Object plist) +hash_table_instantiate (Lisp_Object plist) { - /* I'm not sure whether this can GC, but better safe than sorry. */ - Lisp_Object hashtab = Qnil; - Lisp_Object type = Qnil, test = Qnil, size = Qnil, data = Qnil; - struct gcpro gcpro1; - GCPRO1 (hashtab); + Lisp_Object hash_table; + Lisp_Object test = Qnil; + Lisp_Object type = Qnil; + Lisp_Object size = Qnil; + Lisp_Object data = Qnil; + Lisp_Object rehash_size = Qnil; + Lisp_Object rehash_threshold = Qnil; while (!NILP (plist)) { @@ -359,808 +663,596 @@ 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 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)); - /* 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 (); - - /* 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; - - 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); -} - -/* Basic conversion and allocation functions. */ + /* 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; + } -/* 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) -{ - int len = XVECTOR_LENGTH (ht->harray); - - 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); + return hash_table; } static void -ht_copy_from_c (c_hashtable c_table, struct hashtable *ht) +structure_type_create_hash_table_structure_name (Lisp_Object structure_name) { - struct Lisp_Vector dummy; - /* C is truly hateful */ - void *vec_addr - = ((char *) c_table->harray - - ((char *) &(dummy.contents[0]) - (char *) &dummy)); + struct structure_type *st; - 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; -} - - -static struct hashtable * -allocate_hashtable (void) -{ - 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; + 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); } -void * -elisp_hvector_malloc (unsigned int bytes, Lisp_Object table) -{ - Lisp_Object new_vector; - struct hashtable *ht = XHASHTABLE (table); - - 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); -} - +/* 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 -elisp_hvector_free (void *ptr, Lisp_Object table) +structure_type_create_hash_table (void) { - struct hashtable *ht = XHASHTABLE (table); -#if defined (USE_ASSERTIONS) || defined (DEBUG_XEMACS) - Lisp_Object current_vector = ht->harray; -#endif - - assert (((void *) XVECTOR_DATA (current_vector)) == ptr); - ht->harray = Qnil; /* Let GC do its job */ + structure_type_create_hash_table_structure_name (Qhash_table); + structure_type_create_hash_table_structure_name (Qhashtable); /* compat */ } - -DEFUN ("hashtablep", Fhashtablep, 1, 1, 0, /* -Return t if OBJ is a hashtable, else nil. -*/ - (obj)) -{ - return HASHTABLEP (obj) ? Qt : Qnil; -} - - - -#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) -{ - /* 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)); -} +/************************************************************************/ +/* Definition of Lisp-visible methods */ +/************************************************************************/ -unsigned long -lisp_string_hash (CONST void *x) +DEFUN ("hash-table-p", Fhash_table_p, 1, 1, 0, /* +Return t if OBJECT is a hash table, else nil. +*/ + (object)) { - Lisp_Object str; - CVOID_TO_LISP (str, x); - return hash_string (XSTRING_DATA (str), XSTRING_LENGTH (str)); -} - -#endif /* 0 */ - -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); + return HASH_TABLEP (object) ? Qt : Qnil; } -static unsigned long -lisp_object_eql_hash (CONST void *x) +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) + +Keyword :size specifies the number of keys likely to be inserted. +This number of entries can be inserted without enlarging the hash table. + +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'. + +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. + +A value-weak hash table is similar to a fully-weak hash table except +that a key-value pair will be removed only if the value remains +unmarked outside of weak hash tables. The pair will remain in the +hash table if the value is pointed to by something other than a weak +hash table, even if the key is not. + +Keyword :rehash-size must be a float greater than 1.0, and specifies +the factor by which to increase the size of the hash table when enlarging. + +Keyword :rehash-threshold must be a float between 0.0 and 1.0, +and specifies the load factor of the hash table which triggers enlarging. + +*/ + (int nargs, Lisp_Object *args)) { - Lisp_Object obj; - CVOID_TO_LISP (obj, x); - if (FLOATP (obj)) - return internal_hash (obj, 0); - else - return LISP_HASH (obj); -} + 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++]; -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 (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)); } -static unsigned long -lisp_object_equal_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 obj; - CVOID_TO_LISP (obj, x); - return internal_hash (obj, 0); + CONST Lisp_Hash_Table *ht_old = xhash_table (hash_table); + Lisp_Hash_Table *ht = alloc_lcrecord_type (Lisp_Hash_Table, lrecord_hash_table); + + copy_lcrecord (ht, ht_old); + + ht->hentries = xnew_array (hentry, ht_old->size + 1); + memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (hentry)); + + XSETHASH_TABLE (hash_table, ht); + + if (! EQ (ht->next_weak, Qunbound)) + { + ht->next_weak = Vall_weak_hash_tables; + Vall_weak_hash_tables = hash_table; + } + + 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; + + old_size = ht->size; + new_size = ht->size = + hash_table_size ((size_t) ((double) old_size * ht->rehash_size)); + + old_entries = ht->hentries; + + ht->hentries = xnew_array (hentry, new_size + 1); + new_entries = ht->hentries; + + old_sentinel = old_entries + old_size; + new_sentinel = new_entries + new_size; + + for (e = new_entries; e <= new_sentinel; e++) + CLEAR_HENTRY (e); - 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; + 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; + } - case HASHTABLE_EQL: - table->test_function = lisp_object_eql_equal; - table->hash_function = lisp_object_eql_hash; + xfree (old_entries); +} + +static hentry * +find_hentry (Lisp_Object key, CONST Lisp_Hash_Table *ht) +{ + hash_table_test_function_t test_function = ht->test_function; + hentry *entries = ht->hentries; + hentry *probe = entries + HASH_CODE (key, ht); + + LINEAR_PROBING_LOOP (probe, entries, ht->size) + if (KEYS_EQUAL_P (probe->key, key, test_function)) break; - case HASHTABLE_EQUAL: - table->test_function = lisp_object_equal_equal; - table->hash_function = lisp_object_equal_hash; - break; - - default: - abort (); - } + return probe; +} - table->type = type; - XSETHASHTABLE (result, table); +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). +*/ + (key, hash_table, default_)) +{ + CONST Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e = find_hentry (key, ht); - if (table->type != HASHTABLE_NONWEAK) - { - table->next_weak = Vall_weak_hashtables; - Vall_weak_hashtables = result; - } - else - table->next_weak = Qunbound; - - return result; + return HENTRY_CLEAR_P (e) ? default_ : e->value; } -static enum hashtable_test_fun -decode_hashtable_test_fun (Lisp_Object sym) +DEFUN ("puthash", Fputhash, 3, 3, 0, /* +Hash KEY to VALUE in HASH-TABLE. +*/ + (key, value, hash_table)) { - 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; - - signal_simple_error ("Invalid hashtable test function", sym); - return HASHTABLE_EQ; /* not reached */ -} + Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e = find_hentry (key, ht); -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. + if (!HENTRY_CLEAR_P (e)) + return e->value = value; -See also `make-weak-hashtable', `make-key-weak-hashtable', and -`make-value-weak-hashtable'. -*/ - (size, test_fun)) -{ - CHECK_NATNUM (size); - return make_lisp_hashtable (XINT (size), HASHTABLE_NONWEAK, - decode_hashtable_test_fun (test_fun)); + e->key = key; + e->value = value; + + if (++ht->count >= ht->rehash_count) + enlarge_hash_table (ht); + + return 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. -*/ - (hashtable)) +/* 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) { - 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); + size_t size = ht->size; + CLEAR_HENTRY (probe++); + ht->count--; - /* 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 + LINEAR_PROBING_LOOP (probe, entries, size) { - new_ht->next_weak = Vall_weak_hashtables; - Vall_weak_hashtables = result; + 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; } - - return result; } - -DEFUN ("gethash", Fgethash, 2, 3, 0, /* -Find hash value for KEY in HASHTABLE. -If there is no corresponding value, return DEFAULT (defaults to nil). +DEFUN ("remhash", Fremhash, 2, 2, 0, /* +Remove the entry for KEY from HASH-TABLE. +Do nothing if there is no entry for KEY in HASH-TABLE. */ - (key, hashtable, default_)) + (key, hash_table)) { - 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)) - { - Lisp_Object val; - CVOID_TO_LISP (val, vval); - return val; - } - else - return default_; -} - - -DEFUN ("remhash", Fremhash, 2, 2, 0, /* -Remove hash value for KEY in HASHTABLE. -*/ - (key, hashtable)) -{ - 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; -} - - -DEFUN ("puthash", Fputhash, 3, 3, 0, /* -Hash KEY to VAL in HASHTABLE. -*/ - (key, val, hashtable)) -{ - struct hashtable *ht; - void *vkey = LISP_TO_VOID (key); + if (HENTRY_CLEAR_P (e)) + return Qnil; - 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; + remhash_1 (ht, ht->hentries, e); + return Qt; } DEFUN ("clrhash", Fclrhash, 1, 1, 0, /* -Remove all entries from HASHTABLE. +Remove all entries from HASH-TABLE, leaving it empty. */ - (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; + Lisp_Hash_Table *ht = xhash_table (hash_table); + hentry *e, *sentinel; + + for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) + CLEAR_HENTRY (e); + ht->count = 0; + + return hash_table; } -DEFUN ("hashtable-fullness", Fhashtable_fullness, 1, 1, 0, /* -Return number of entries in 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); - return make_int (htbl.fullness); + return make_int (xhash_table (hash_table)->count); } -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-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)) { - CHECK_HASHTABLE (hashtable); + return make_int (xhash_table (hash_table)->size); +} - switch (XHASHTABLE (hashtable)->type) +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'. +*/ + (hash_table)) +{ + 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 *); + hash_table_test_function_t fun = xhash_table (hash_table)->test_function; - CHECK_HASHTABLE (hashtable); + return (fun == lisp_object_eql_equal ? Qeql : + fun == lisp_object_equal_equal ? Qequal : + Qeq); +} - fun = XHASHTABLE (hashtable)->test_function; - - if (fun == lisp_object_eql_equal) - return Qeql; - else if (fun == lisp_object_equal_equal) - return Qequal; - else - return Qeq; +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)) +{ + return make_float (xhash_table (hash_table)->rehash_size); } -static void -verify_function (Lisp_Object function, CONST char *description) +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)) { - /* #### 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 (hash_table_rehash_threshold (xhash_table (hash_table))); } -static int -lisp_maphash_function (CONST void *void_key, - void *void_val, - void *void_fn) +/************************************************************************/ +/* Mapping Functions */ +/************************************************************************/ +DEFUN ("maphash", Fmaphash, 2, 2, 0, /* +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, 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; -} - + CONST Lisp_Hash_Table *ht = xhash_table (hash_table); + CONST hentry *e, *sentinel; -DEFUN ("maphash", Fmaphash, 2, 2, 0, /* -Map FUNCTION over entries in HASHTABLE, calling it with two args, -each key and value in the table. -*/ - (function, hashtable)) -{ - struct _C_hashtable htbl; - struct gcpro gcpro1, gcpro2; + 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; + } - 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; } - -/* This function is for mapping a *C* function over the elements of a - lisp hashtable. - */ +/* Map *C* function FUNCTION over the elements of a lisp hash table. */ void -elisp_maphash (int (*function) (CONST void *key, void *contents, - void *extra_arg), - 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); - maphash (function, &htbl, closure); -} - -void -elisp_map_remhash (remhash_predicate function, Lisp_Object hashtable, - void *closure) -{ - struct _C_hashtable htbl; - - 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) -{ - struct _C_hashtable htbl; - CHECK_HASHTABLE (table); - ht_copy_to_c (XHASHTABLE (table), &htbl); - (*op) (&htbl, arg1, arg2, arg3); - ht_copy_from_c (&htbl, XHASHTABLE (table)); -} -#endif /* 0 */ - - - -DEFUN ("make-weak-hashtable", Fmake_weak_hashtable, 1, 2, 0, /* -Return a new fully weak hashtable object of initial size SIZE. -A weak hashtable is one whose pointers do not count as GC referents: -for any key-value pair in the hashtable, if the only remaining pointer -to either the key or the value is in a weak hash table, then the pair -will be removed from the table, and the key and value collected. A -non-weak hash table (or any other pointer) would prevent the object -from being collected. - -You can also create semi-weak hashtables; see `make-key-weak-hashtable' -and `make-value-weak-hashtable'. -*/ - (size, test_fun)) +elisp_map_remhash (maphash_function_t predicate, + Lisp_Object hash_table, void *extra_arg) { - CHECK_NATNUM (size); - return make_lisp_hashtable (XINT (size), HASHTABLE_WEAK, - decode_hashtable_test_fun (test_fun)); -} + Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); + hentry *e, *entries, *sentinel; -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; + +/************************************************************************/ +/* garbage collecting weak hash tables */ +/************************************************************************/ - 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; -} - +/* 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 (hash_table)) + /* The hash table is probably garbage. Ignore it. */ + continue; - if (! ((*obj_marked_p) (rest))) - /* The hashtable 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; + 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; - 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_VALUE_WEAK: + for (; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + if (obj_marked_p (e->value)) + MARK_OBJ (e->key); + 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) */ - } + 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; + } } return did_mark; } -struct pruning_closure -{ - int (*obj_marked_p) (Lisp_Object); -}; - -static int -pruning_mapper (CONST void *key, CONST void *contents, void *closure) +void +prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object)) { - 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)) -{ - Lisp_Object rest, prev = Qnil; - for (rest = Vall_weak_hashtables; - !GC_NILP (rest); - rest = XHASHTABLE (rest)->next_weak) + Lisp_Object hash_table, prev = Qnil; + for (hash_table = Vall_weak_hash_tables; + !GC_NILP (hash_table); + hash_table = XHASH_TABLE (hash_table)->next_weak) { - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (hash_table)) { - /* This table itself is garbage. Remove it from the list. */ + /* This hash table itself is garbage. Remove it from the list. */ if (GC_NILP (prev)) - Vall_weak_hashtables = XHASHTABLE (rest)->next_weak; + Vall_weak_hash_tables = XHASH_TABLE (hash_table)->next_weak; else - XHASHTABLE (prev)->next_weak = XHASHTABLE (rest)->next_weak; + XHASH_TABLE (prev)->next_weak = XHASH_TABLE (hash_table)->next_weak; } else { - struct pruning_closure fmh; - fmh.obj_marked_p = obj_marked_p; /* Now, scan over all the pairs. Remove all of the pairs in which the key or value, or both, is unmarked - (depending on the type of weak hashtable). */ - elisp_map_remhash (pruning_mapper, rest, &fmh); - prev = rest; + (depending on the type of weak hash table). */ + Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); + hentry *entries = ht->hentries; + hentry *sentinel = entries + ht->size; + hentry *e; + + for (e = entries; e < sentinel; e++) + if (!HENTRY_CLEAR_P (e)) + { + again: + if (!obj_marked_p (e->key) || !obj_marked_p (e->value)) + { + remhash_1 (ht, entries, e); + if (!HENTRY_CLEAR_P (e)) + goto again; + } + } + + prev = hash_table; } } } /* Return a hash value for an array of Lisp_Objects of size SIZE. */ -unsigned long +hashcode_t internal_array_hash (Lisp_Object *arr, int size, int depth) { int i; @@ -1194,7 +1286,7 @@ we could still take 5^5 time (a big big number) to compute a hash, but practically this won't ever happen. */ -unsigned long +hashcode_t internal_hash (Lisp_Object obj, int depth) { if (depth > 5) @@ -1206,21 +1298,23 @@ 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)) { - struct Lisp_Vector *v = XVECTOR (obj); - return HASH2 (vector_length (v), - internal_array_hash (v->contents, vector_length (v), + return hash_string (XSTRING_DATA (obj), XSTRING_LENGTH (obj)); + } + if (VECTORP (obj)) + { + return HASH2 (XVECTOR_LENGTH (obj), + internal_array_hash (XVECTOR_DATA (obj), + XVECTOR_LENGTH (obj), depth + 1)); } - else if (LRECORDP (obj)) + if (LRECORDP (obj)) { CONST struct lrecord_implementation *imp = XRECORD_LHEADER_IMPLEMENTATION (obj); if (imp->hash) - return (imp->hash) (obj, depth); + return imp->hash (obj, depth); } return LISP_HASH (obj); @@ -1247,34 +1341,44 @@ 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 (Fremhash); DEFSUBR (Fputhash); - DEFSUBR (Fremhash); DEFSUBR (Fclrhash); DEFSUBR (Fmaphash); - DEFSUBR (Fhashtable_fullness); - DEFSUBR (Fhashtable_type); - DEFSUBR (Fhashtable_test_function); - DEFSUBR (Fmake_weak_hashtable); - DEFSUBR (Fmake_key_weak_hashtable); - DEFSUBR (Fmake_value_weak_hashtable); + DEFSUBR (Fhash_table_count); + DEFSUBR (Fhash_table_size); + DEFSUBR (Fhash_table_rehash_size); + DEFSUBR (Fhash_table_rehash_threshold); + DEFSUBR (Fhash_table_type); + DEFSUBR (Fhash_table_test); #if 0 DEFSUBR (Finternal_hash_value); #endif - defsymbol (&Qhashtablep, "hashtablep"); + + defsymbol (&Qhash_tablep, "hash-table-p"); + defsymbol (&Qhash_table, "hash-table"); defsymbol (&Qhashtable, "hashtable"); defsymbol (&Qweak, "weak"); defsymbol (&Qkey_weak, "key-weak"); defsymbol (&Qvalue_weak, "value-weak"); defsymbol (&Qnon_weak, "non-weak"); + defsymbol (&Qrehash_size, "rehash-size"); + defsymbol (&Qrehash_threshold, "rehash-threshold"); + + defkeyword (&Q_size, ":size"); + defkeyword (&Q_test, ":test"); + defkeyword (&Q_type, ":type"); + defkeyword (&Q_rehash_size, ":rehash-size"); + defkeyword (&Q_rehash_threshold, ":rehash-threshold"); } void vars_of_elhash (void) { /* This must NOT be staticpro'd */ - Vall_weak_hashtables = Qnil; + Vall_weak_hash_tables = Qnil; } diff -r 76b7d63099ad -r 8626e4521993 src/elhash.h --- a/src/elhash.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/elhash.h Mon Aug 13 11:07:10 2007 +0200 @@ -23,56 +23,64 @@ #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); + +Lisp_Object make_lisp_hash_table (size_t size, + enum hash_table_type type, + enum hash_table_test test); -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)); +void elisp_maphash (maphash_function_t function, + Lisp_Object hash_table, void *extra_arg); -void *elisp_hvector_malloc (unsigned int, Lisp_Object); -void elisp_hvector_free (void *ptr, Lisp_Object table); +void elisp_map_remhash (maphash_function_t predicate, + Lisp_Object hash_table, void *extra_arg); + +int finish_marking_weak_hash_tables (int (*obj_marked_p) (Lisp_Object), + void (*markobj) (Lisp_Object)); +void prune_weak_hash_tables (int (*obj_marked_p) (Lisp_Object)); #endif /* _XEMACS_ELHASH_H_ */ diff -r 76b7d63099ad -r 8626e4521993 src/emacs.c --- a/src/emacs.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/emacs.c Mon Aug 13 11:07:10 2007 +0200 @@ -35,14 +35,18 @@ #include "commands.h" #include "console.h" #include "process.h" +#include "redisplay.h" #include "sysdep.h" -#include #include "syssignal.h" /* Always include before systty.h */ #include "systty.h" #include "sysfile.h" #include "systime.h" +#ifdef QUANTIFY +#include +#endif + #ifdef HAVE_SHLIB #include "sysdll.h" #endif @@ -212,8 +216,6 @@ static void sort_args (int argc, char **argv); -extern int always_gc; /* hack */ - Lisp_Object Qkill_emacs_hook; Lisp_Object Qsave_buffers_kill_emacs; @@ -445,7 +447,7 @@ #endif #if defined (MULE) && defined (MSDOS) && defined (EMX) -/* Setup all of files be input/output'ed with binary translation mdoe. */ +/* Setup all of files be input/output'ed with binary translation mode. */ asm (" .text"); asm ("L_setbinmode:"); asm (" movl $1, __fmode_bin"); @@ -519,7 +521,10 @@ /* Make stack traces always identify version + configuration */ #define main_1 STACK_TRACE_EYE_CATCHER -static DOESNT_RETURN +/* This function is not static, so that the compiler is less likely to + inline it, which would make it not show up in stack traces. */ +DECLARE_DOESNT_RETURN (main_1 (int, char **, char **, int)); +DOESNT_RETURN main_1 (int argc, char **argv, char **envp, int restart) { char stack_bottom_variable; @@ -894,6 +899,9 @@ syms_of_elhash (); syms_of_emacs (); syms_of_eval (); +#ifdef HAVE_X_WINDOWS + syms_of_event_Xt (); +#endif #ifdef HAVE_DRAGNDROP syms_of_dragdrop (); #endif @@ -964,12 +972,12 @@ syms_of_device_tty (); syms_of_objects_tty (); #endif + #ifdef HAVE_X_WINDOWS syms_of_device_x (); #ifdef HAVE_DIALOGS syms_of_dialog_x (); #endif - syms_of_event_Xt (); syms_of_frame_x (); syms_of_glyphs_x (); syms_of_objects_x (); @@ -985,7 +993,6 @@ #ifdef HAVE_MS_WINDOWS syms_of_console_mswindows (); syms_of_device_mswindows (); - syms_of_event_mswindows (); syms_of_frame_mswindows (); syms_of_objects_mswindows (); syms_of_select_mswindows (); @@ -1026,10 +1033,6 @@ SYMS_MACHINE; #endif -#ifdef EMACS_BTL - syms_of_btl (); -#endif - /* #if defined (GNU_MALLOC) && \ defined (ERROR_CHECK_MALLOC) && \ @@ -1152,7 +1155,7 @@ structure_type_create_chartab (); structure_type_create_faces (); structure_type_create_rangetab (); - structure_type_create_hashtable (); + structure_type_create_hash_table (); /* Now initialize the image instantiator formats and associated symbols. Other than the first function below, the functions may @@ -1189,7 +1192,7 @@ #if defined (HAVE_MS_WINDOWS) && !defined(HAVE_MSG_SELECT) lstream_type_create_mswindows_selectable (); #endif - + /* Initialize processes implementation. The functions may make exactly the following function/macro calls: @@ -1276,7 +1279,18 @@ vars_of_elhash (); vars_of_emacs (); vars_of_eval (); + +#ifdef HAVE_X_WINDOWS + vars_of_event_Xt (); +#endif +#if defined(HAVE_TTY) && (defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS)) + vars_of_event_tty (); +#endif +#ifdef HAVE_MS_WINDOWS + vars_of_event_mswindows (); +#endif vars_of_event_stream (); + vars_of_events (); vars_of_extents (); vars_of_faces (); @@ -1345,7 +1359,6 @@ #ifdef HAVE_TTY vars_of_console_tty (); - vars_of_event_tty (); vars_of_frame_tty (); vars_of_objects_tty (); #endif @@ -1355,7 +1368,6 @@ #ifdef HAVE_DIALOGS vars_of_dialog_x (); #endif - vars_of_event_Xt (); vars_of_frame_x (); vars_of_glyphs_x (); #ifdef HAVE_MENUBARS @@ -1374,7 +1386,6 @@ #ifdef HAVE_MS_WINDOWS vars_of_device_mswindows (); vars_of_console_mswindows (); - vars_of_event_mswindows (); vars_of_frame_mswindows (); vars_of_objects_mswindows (); vars_of_select_mswindows (); @@ -1458,14 +1469,14 @@ /* Calls Fmake_range_table(). */ complex_vars_of_search (); - /* Calls make_lisp_hashtable(). */ + /* Calls make_lisp_hash_table(). */ complex_vars_of_extents (); - /* Depends on hashtables and specifiers. */ + /* Depends on hash tables and specifiers. */ complex_vars_of_faces (); #ifdef MULE - /* These two depend on hashtables and various variables declared + /* These two depend on hash tables and various variables declared earlier. The second may also depend on the first. */ complex_vars_of_mule_charset (); #endif @@ -1536,15 +1547,21 @@ complex_vars_of_emacs (); /* This creates a couple of basic keymaps and depends on Lisp - hashtables and Ffset() (both of which depend on some variables + hash tables and Ffset() (both of which depend on some variables initialized in the vars_of_*() section) and possibly other stuff. */ complex_vars_of_keymap (); - /* Calls Fmake_hashtable() and creates a keymap */ + + /* Calls make_lisp_hash_table() and creates a keymap */ complex_vars_of_event_stream (); - if (always_gc) /* purification debugging hack */ - garbage_collect_1 (); +#ifdef ERROR_CHECK_GC + { + extern int always_gc; + if (always_gc) /* purification debugging hack */ + garbage_collect_1 (); + } +#endif } /* CONGRATULATIONS!!! We have successfully initialized the Lisp @@ -1574,7 +1591,7 @@ #ifdef WINDOWSNT /* * For Win32, call init_environment() now, so that environment/registry - * variables will be properly entered into Vprocess_envonment. + * variables will be properly entered into Vprocess_environment. */ init_environment(); #endif @@ -1657,11 +1674,11 @@ char *buf = (char *)alloca (XSTRING_LENGTH (Vinvocation_directory) + XSTRING_LENGTH (Vinvocation_name) + 2); - sprintf (buf, "%s/%s", XSTRING_DATA(Vinvocation_directory), - XSTRING_DATA(Vinvocation_name)); + sprintf (buf, "%s/%s", XSTRING_DATA (Vinvocation_directory), + XSTRING_DATA (Vinvocation_name)); /* All we can do is cry if an error happens, so ignore it. */ - (void)dll_init(buf); + (void) dll_init (buf); } #endif @@ -1791,7 +1808,7 @@ static void sort_args (int argc, char **argv) { - char **new = xnew_array (char *, argc); + char **new_argv = xnew_array (char *, argc); /* For each element of argv, the corresponding element of options is: 0 for an option that takes no arguments, @@ -1871,8 +1888,8 @@ } } - /* Copy the arguments, in order of decreasing priority, to NEW. */ - new[0] = argv[0]; + /* Copy the arguments, in order of decreasing priority, to NEW_ARGV. */ + new_argv[0] = argv[0]; while (to < argc) { int best = -1; @@ -1895,10 +1912,10 @@ if (best < 0) abort (); - /* Copy the highest priority remaining option, with its args, to NEW. */ - new[to++] = argv[best]; + /* Copy the highest priority remaining option, with its args, to NEW_ARGV. */ + new_argv[to++] = argv[best]; for (i = 0; i < options[best]; i++) - new[to++] = argv[best + i + 1]; + new_argv[to++] = argv[best + i + 1]; /* Clear out this option in ARGV. */ argv[best] = 0; @@ -1906,7 +1923,10 @@ argv[best + i + 1] = 0; } - memcpy (argv, new, sizeof (char *) * argc); + memcpy (argv, new_argv, sizeof (char *) * argc); + xfree (new_argv); + xfree (options); + xfree (priority); } static JMP_BUF run_temacs_catch; @@ -1938,7 +1958,9 @@ a dumped version in case you want to rerun it. This function is most useful when used as part of the `make all-elc' command. --ben] This will "restart" emacs with the specified command-line arguments. - */ + + Martin thinks this function is most useful when using debugging + tools like Purify or tcov that get confused by XEmacs' dumping. */ (int nargs, Lisp_Object *args)) { int ac; @@ -1988,11 +2010,13 @@ unbind_to (0, Qnil); /* this closes loadup.el */ purify_flag = 0; run_temacs_argc = nargs + 1; +#if 0 #ifdef REPORT_PURE_USAGE report_pure_usage (1, 0); #else report_pure_usage (0, 0); #endif +#endif /* 0 */ LONGJMP (run_temacs_catch, 1); return Qnil; /* not reached; warning suppression */ } @@ -2004,28 +2028,33 @@ int volatile vol_argc = argc; char ** volatile vol_argv = argv; char ** volatile vol_envp = envp; - /* This is hairy. We need to compute where the XEmacs binary was invoked */ - /* from because temacs initialization requires it to find the lisp */ - /* directories. The code that recomputes the path is guarded by the */ - /* restarted flag. There are three possible paths I've found so far */ - /* through this: */ - /* temacs -- When running temacs for basic build stuff, the first main_1 */ - /* will be the only one invoked. It must compute the path else there */ - /* will be a very ugly bomb in startup.el (can't find obvious location */ - /* for doc-directory data-directory, etc.). */ - /* temacs w/ run-temacs on the command line -- This is run to bytecompile */ - /* all the out of date dumped lisp. It will execute both of the main_1 */ - /* calls and the second one must not touch the first computation because */ - /* argc/argv are hosed the second time through. */ - /* xemacs -- Only the second main_1 is executed. The invocation path must */ - /* computed but this only matters when running in place or when running */ - /* as a login shell. */ - /* As a bonus for straightening this out, XEmacs can now be run in place */ - /* as a login shell. This never used to work. */ - /* As another bonus, we can now guarantee that */ - /* (concat invocation-directory invocation-name) contains the filename */ - /* of the XEmacs binary we are running. This can now be used in a */ - /* definite test for out of date dumped files. -slb */ + /* This is hairy. We need to compute where the XEmacs binary was invoked + from because temacs initialization requires it to find the lisp + directories. The code that recomputes the path is guarded by the + restarted flag. There are three possible paths I've found so far + through this: + + temacs -- When running temacs for basic build stuff, the first main_1 + will be the only one invoked. It must compute the path else there + will be a very ugly bomb in startup.el (can't find obvious location + for doc-directory data-directory, etc.). + + temacs w/ run-temacs on the command line -- This is run to bytecompile + all the out of date dumped lisp. It will execute both of the main_1 + calls and the second one must not touch the first computation because + argc/argv are hosed the second time through. + + xemacs -- Only the second main_1 is executed. The invocation path must + computed but this only matters when running in place or when running + as a login shell. + + As a bonus for straightening this out, XEmacs can now be run in place + as a login shell. This never used to work. + + As another bonus, we can now guarantee that + (concat invocation-directory invocation-name) contains the filename + of the XEmacs binary we are running. This can now be used in a + definite test for out of date dumped files. -slb */ int restarted = 0; #ifdef QUANTIFY quantify_stop_recording_data (); @@ -2080,7 +2109,7 @@ } #ifdef RUN_TIME_REMAP else - /* obviously no-one uses this because where it was before initalized was + /* obviously no-one uses this because where it was before initialized was *always* true */ run_time_remap (argv[0]); #endif @@ -2449,10 +2478,10 @@ It's a whole lot easier to do the conversion here than to modify all the unexec routines to ensure that filename conversion is applied everywhere. Don't worry about memory - leakage because this call only happens once. */ - unexec (intoname_ext, symname_ext, (uintptr_t) my_edata, 0, 0); + leakage because this call only happens once. */ + unexec (intoname_ext, symname_ext, (uintptr_t) my_edata, 0, 0); #ifdef DOUG_LEA_MALLOC - free (malloc_state_ptr); + free (malloc_state_ptr); #endif } #endif /* not MSDOS and EMX */ @@ -2605,7 +2634,7 @@ #ifdef QUANTIFY DEFUN ("quantify-start-recording-data", Fquantify_start_recording_data, - 0, 0, 0, /* + 0, 0, "", /* Start recording Quantify data. */ ()) @@ -2615,7 +2644,7 @@ } DEFUN ("quantify-stop-recording-data", Fquantify_stop_recording_data, - 0, 0, 0, /* + 0, 0, "", /* Stop recording Quantify data. */ ()) @@ -2624,7 +2653,7 @@ return Qnil; } -DEFUN ("quantify-clear-data", Fquantify_clear_data, 0, 0, 0, /* +DEFUN ("quantify-clear-data", Fquantify_clear_data, 0, 0, "", /* Clear all Quantify data. */ ()) @@ -2857,7 +2886,7 @@ complex_vars_of_emacs (void) { /* This is all related to path searching. */ - + DEFVAR_LISP ("emacs-program-name", &Vemacs_program_name /* *Name of the Emacs variant. For example, this may be \"xemacs\" or \"infodock\". diff -r 76b7d63099ad -r 8626e4521993 src/eval.c --- a/src/eval.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/eval.c Mon Aug 13 11:07:10 2007 +0200 @@ -21,10 +21,6 @@ /* Synched up with: FSF 19.30 (except for Fsignal), Mule 2.0. */ -/* Debugging hack */ -int always_gc; - - #include #include "lisp.h" @@ -35,17 +31,68 @@ #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 POP_BACKTRACE(bt) \ - do { backtrace_list = (bt).next; } 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); + /* This is the list of current catches (and also condition-cases). This is a stack: the most recent catch is at the head of the @@ -80,6 +127,7 @@ Lisp_Object Qsetq; Lisp_Object Qdisplay_warning; Lisp_Object Vpending_warnings, Vpending_warnings_tail; +Lisp_Object Qif; /* Records whether we want errors to occur. This will be a boolean, nil (errors OK) or t (no errors). If t, an error will cause a @@ -104,11 +152,10 @@ if the file being autoloaded is not fully loaded. They are recorded by being consed onto the front of Vautoload_queue: (FUN . ODEF) for a defun, (OFEATURES . nil) for a provide. */ - Lisp_Object Vautoload_queue; /* Current number of specbindings allocated in specpdl. */ -static int specpdl_size; +int specpdl_size; /* Pointer to beginning of specpdl. */ struct specbinding *specpdl; @@ -116,9 +163,8 @@ /* Pointer to first unused element in specpdl. */ struct specbinding *specpdl_ptr; -/* specpdl_ptr - specpdl. Callers outside this file should use - * specpdl_depth () function-call */ -static int specpdl_depth_counter; +/* specpdl_ptr - specpdl */ +int specpdl_depth_counter; /* Maximum size allowed for specpdl allocation */ int max_specpdl_size; @@ -221,95 +267,44 @@ */ static Lisp_Object Vcondition_handlers; + +#if 0 /* no longer used */ /* Used for error catching purposes by throw_or_bomb_out */ static int throw_level; - -static Lisp_Object primitive_funcall (lisp_fn_t fn, int nargs, - Lisp_Object args[]); +#endif /* unused */ -/**********************************************************************/ -/* The subr and compiled-function types */ -/**********************************************************************/ +/************************************************************************/ +/* The subr object type */ +/************************************************************************/ static void print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - struct Lisp_Subr *subr = XSUBR (obj); + Lisp_Subr *subr = XSUBR (obj); + CONST char *header = + (subr->max_args == UNEVALLED) ? "#prompt ? " (interactive)>" : ">"; if (print_readably) - error ("printing unreadable object #", - subr_name (subr)); - - write_c_string (((subr->max_args == UNEVALLED) - ? "#prompt) ? " (interactive)>" : ">"), - printcharfun); + error ("printing unreadable object %s%s%s", header, name, trailer); + + 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); + Lisp_Subr); -static Lisp_Object -mark_compiled_function (Lisp_Object obj, void (*markobj) (Lisp_Object)) -{ - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); - - ((markobj) (b->bytecodes)); - ((markobj) (b->arglist)); - ((markobj) (b->doc_and_interactive)); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - ((markobj) (b->annotated)); -#endif - /* tail-recurse on constants */ - return b->constants; -} - -static int -compiled_function_equal (Lisp_Object o1, Lisp_Object o2, int depth) -{ - struct Lisp_Compiled_Function *b1 = XCOMPILED_FUNCTION (o1); - struct Lisp_Compiled_Function *b2 = XCOMPILED_FUNCTION (o2); - return - (b1->flags.documentationp == b2->flags.documentationp && - b1->flags.interactivep == b2->flags.interactivep && - b1->flags.domainp == b2->flags.domainp && /* I18N3 */ - internal_equal (b1->bytecodes, b2->bytecodes, depth + 1) && - internal_equal (b1->constants, b2->constants, depth + 1) && - internal_equal (b1->arglist, b2->arglist, depth + 1) && - internal_equal (b1->doc_and_interactive, - b2->doc_and_interactive, depth + 1)); -} - -static unsigned long -compiled_function_hash (Lisp_Object obj, int depth) -{ - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (obj); - return HASH3 ((b->flags.documentationp << 2) + - (b->flags.interactivep << 1) + - b->flags.domainp, - internal_hash (b->bytecodes, depth + 1), - internal_hash (b->constants, depth + 1)); -} - -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, - mark_compiled_function, - print_compiled_function, 0, - compiled_function_equal, - compiled_function_hash, - struct Lisp_Compiled_Function); - -/**********************************************************************/ -/* Entering the debugger */ -/**********************************************************************/ +/************************************************************************/ +/* Entering the debugger */ +/************************************************************************/ /* unwind-protect used by call_debugger() to restore the value of - enterring_debugger. (We cannot use specbind() because the + entering_debugger. (We cannot use specbind() because the variable is not Lisp-accessible.) */ static Lisp_Object @@ -337,12 +332,12 @@ } /* Call the debugger, doing some encapsulation. We make sure we have - some room on the eval and specpdl stacks, and bind enterring_debugger + some room on the eval and specpdl stacks, and bind entering_debugger to 1 during this call. This is used to trap errors that may occur - when enterring the debugger (e.g. the value of `debugger' is invalid), + when entering the debugger (e.g. the value of `debugger' is invalid), so that the debugger will not be recursively entered if debug-on-error is set. (Otherwise, XEmacs would infinitely recurse, attempting to - enter the debugger.) enterring_debugger gets reset to 0 as soon + enter the debugger.) entering_debugger gets reset to 0 as soon as a backtrace is displayed, so that further errors can indeed be handled normally. @@ -383,7 +378,7 @@ max_specpdl_size = specpdl_size + 40; debug_on_next_call = 0; - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); record_unwind_protect (restore_entering_debugger, (entering_debugger ? Qt : Qnil)); entering_debugger = 1; @@ -542,7 +537,7 @@ Lisp_Object val = Qunbound; Lisp_Object all_handlers = Vcondition_handlers; Lisp_Object temp_data = Qnil; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); struct gcpro gcpro1, gcpro2; GCPRO2 (all_handlers, temp_data); @@ -554,12 +549,12 @@ && wants_debugger (Vstack_trace_on_error, conditions) && !skip_debugger (conditions, temp_data)) { - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); - internal_with_output_to_temp_buffer ("*Backtrace*", + internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), backtrace_259, Qnil, Qnil); @@ -574,9 +569,9 @@ && !skip_debugger (conditions, temp_data)) { debug_on_quit &= ~2; /* reset critical bit */ - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); @@ -586,12 +581,12 @@ if (!entering_debugger && !*stack_trace_displayed && wants_debugger (Vstack_trace_on_signal, conditions)) { - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); - internal_with_output_to_temp_buffer ("*Backtrace*", + internal_with_output_to_temp_buffer (build_string ("*Backtrace*"), backtrace_259, Qnil, Qnil); @@ -605,9 +600,9 @@ : wants_debugger (Vdebug_on_signal, conditions))) { debug_on_quit &= ~2; /* reset critical bit */ - specbind (Qdebug_on_error, Qnil); - specbind (Qstack_trace_on_error, Qnil); - specbind (Qdebug_on_signal, Qnil); + specbind (Qdebug_on_error, Qnil); + specbind (Qstack_trace_on_error, Qnil); + specbind (Qdebug_on_signal, Qnil); specbind (Qstack_trace_on_signal, Qnil); val = call_debugger (list2 (Qerror, (Fcons (sig, data)))); @@ -620,13 +615,12 @@ } -/**********************************************************************/ -/* 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. */ +/************************************************************************/ +/* The basic special forms */ +/************************************************************************/ + +/* Except for Fprogn(), the basic special forms below are only called + from interpreted code. The byte compiler turns them into bytecodes. */ DEFUN ("or", For, 0, UNEVALLED, 0, /* Eval args until one of them yields non-nil, then return that value. @@ -636,22 +630,14 @@ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail; - struct gcpro gcpro1; - - GCPRO1 (args); - - LIST_LOOP (tail, args) + REGISTER Lisp_Object arg, val; + + LIST_LOOP_2 (arg, args) { - Lisp_Object val = Feval (XCAR (tail)); - if (!NILP (val)) - { - UNGCPRO; - return val; - } + if (!NILP (val = Feval (arg))) + return val; } - UNGCPRO; return Qnil; } @@ -663,19 +649,14 @@ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail, val = Qt; - struct gcpro gcpro1; - - GCPRO1 (args); - - LIST_LOOP (tail, args) + REGISTER Lisp_Object arg, val = Qt; + + LIST_LOOP_2 (arg, args) { - val = Feval (XCAR (tail)); - if (NILP (val)) - break; + if (NILP (val = Feval (arg))) + return val; } - UNGCPRO; return val; } @@ -688,18 +669,47 @@ (args)) { /* This function can GC */ - Lisp_Object val; - struct gcpro gcpro1; - - GCPRO1 (args); - - if (!NILP (Feval (XCAR (args)))) - val = Feval (XCAR (XCDR ((args)))); + Lisp_Object condition = XCAR (args); + Lisp_Object then_form = XCAR (XCDR (args)); + Lisp_Object else_forms = XCDR (XCDR (args)); + + if (!NILP (Feval (condition))) + return Feval (then_form); else - val = Fprogn (XCDR (XCDR (args))); - - UNGCPRO; - return val; + return Fprogn (else_forms); +} + +/* Macros `when' and `unless' are trivially defined in Lisp, + but it helps for bootstrapping to have them ALWAYS defined. */ + +DEFUN ("when", Fwhen, 1, MANY, 0, /* +\(when COND BODY...): if COND yields non-nil, do BODY, else return nil. +BODY can be zero or more expressions. If BODY is nil, return nil. +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object cond = args[0]; + Lisp_Object body; + + switch (nargs) + { + case 1: body = Qnil; break; + case 2: body = args[1]; break; + default: body = Fcons (Qprogn, Flist (nargs-1, args+1)); break; + } + + return list3 (Qif, cond, body); +} + +DEFUN ("unless", Funless, 1, MANY, 0, /* +\(unless COND BODY...): if COND yields nil, do BODY, else return nil. +BODY can be zero or more expressions. If BODY is nil, return nil. +*/ + (int nargs, Lisp_Object *args)) +{ + Lisp_Object cond = args[0]; + Lisp_Object body = Flist (nargs-1, args+1); + return Fcons (Qif, Fcons (cond, Fcons (Qnil, body))); } DEFUN ("cond", Fcond, 0, UNEVALLED, 0, /* @@ -715,30 +725,21 @@ (args)) { /* This function can GC */ - REGISTER Lisp_Object tail; - struct gcpro gcpro1; - - GCPRO1 (args); - - LIST_LOOP (tail, args) + REGISTER Lisp_Object val, clause; + + LIST_LOOP_2 (clause, args) { - Lisp_Object val; - Lisp_Object clause = XCAR (tail); CHECK_CONS (clause); - val = Feval (XCAR (clause)); - if (!NILP (val)) + if (!NILP (val = Feval (XCAR (clause)))) { - Lisp_Object clause_tail = XCDR (clause); - if (!NILP (clause_tail)) + if (!NILP (clause = XCDR (clause))) { - CHECK_TRUE_LIST (clause_tail); - val = Fprogn (clause_tail); + CHECK_TRUE_LIST (clause); + val = Fprogn (clause); } - UNGCPRO; return val; } } - UNGCPRO; return Qnil; } @@ -749,61 +750,70 @@ (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; - - GCPRO2 (args, val); - - val = Feval (XCAR (tail)); - - LIST_LOOP (tail, XCDR (tail)) - Feval (XCAR (tail)); + REGISTER Lisp_Object val, form; + struct gcpro gcpro1; + + val = Feval (XCAR (args)); + + GCPRO1 (val); + + { + 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; - - GCPRO2 (args, val); - - Feval (XCAR (tail)); - tail = XCDR (tail); - val = Feval (XCAR (tail)); - - LIST_LOOP (tail, XCDR (tail)) - Feval (XCAR (tail)); + REGISTER Lisp_Object val, form, tail; + struct gcpro gcpro1; + + Feval (XCAR (args)); + args = XCDR (args); + val = Feval (XCAR (args)); + args = XCDR (args); + + GCPRO1 (val); + + LIST_LOOP_3 (form, args, tail) + Feval (form); UNGCPRO; return val; @@ -819,42 +829,35 @@ (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; - - GCPRO1 (args); - - EXTERNAL_LIST_LOOP (tail, varlist) + Lisp_Object body = XCDR (args); + int speccount = specpdl_depth(); + + EXTERNAL_LIST_LOOP_3 (var, varlist, tail) { - Lisp_Object elt = XCAR (tail); - QUIT; - if (SYMBOLP (elt)) - specbind (elt, Qnil); + Lisp_Object symbol, value, tem; + if (SYMBOLP (var)) + symbol = var, value = Qnil; else { - Lisp_Object sym, form; - CHECK_CONS (elt); - sym = XCAR (elt); - elt = XCDR (elt); - if (NILP (elt)) - form = Qnil; + CHECK_CONS (var); + symbol = XCAR (var); + tem = XCDR (var); + if (NILP (tem)) + value = Qnil; else { - CHECK_CONS (elt); - form = XCAR (elt); - elt = XCDR (elt); - if (!NILP (elt)) + CHECK_CONS (tem); + value = Feval (XCAR (tem)); + if (!NILP (XCDR (tem))) signal_simple_error - ("`let' bindings can have only one value-form", - XCAR (tail)); + ("`let' bindings can have only one value-form", var); } - specbind (sym, Feval (form)); } + specbind (symbol, value); } - UNGCPRO; - return unbind_to (speccount, Fprogn (XCDR (args))); + return unbind_to (speccount, Fprogn (body)); } DEFUN ("let", Flet, 1, UNEVALLED, 0, /* @@ -867,61 +870,60 @@ (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' */ - - GCPRO2 (args, *temps); - gcpro2.nvars = 0; - - LIST_LOOP (tail, varlist) + GCPRO1 (*temps); + gcpro1.nvars = 0; + + 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; - - if (!NILP (XCDR (elt))) + CHECK_CONS (tem); + *value = Feval (XCAR (tem)); + gcpro1.nvars = idx; + + if (!NILP (XCDR (tem))) signal_simple_error - ("`let' bindings can have only one value-form", - XCAR (tail)); + ("`let' bindings can have only one value-form", var); } } } - UNGCPRO; - - argnum = 0; - LIST_LOOP (tail, varlist) + + idx = 0; + LIST_LOOP_3 (var, varlist, tail) { - Lisp_Object elt = XCAR (tail); - specbind (SYMBOLP (elt) ? elt : XCAR (elt), temps[argnum++]); + specbind (SYMBOLP (var) ? var : XCAR (var), temps[idx++]); } - return unbind_to (speccount, Fprogn (XCDR (args))); + UNGCPRO; + + return unbind_to (speccount, Fprogn (body)); } DEFUN ("while", Fwhile, 1, UNEVALLED, 0, /* @@ -932,20 +934,15 @@ (args)) { /* This function can GC */ - Lisp_Object tem; Lisp_Object test = XCAR (args); Lisp_Object body = XCDR (args); - struct gcpro gcpro1, gcpro2; - - GCPRO2 (test, body); - - while (tem = Feval (test), !NILP (tem)) + + while (!NILP (Feval (test))) { QUIT; Fprogn (body); } - UNGCPRO; return Qnil; } @@ -961,34 +958,21 @@ (args)) { /* This function can GC */ + Lisp_Object symbol, tail, val = Qnil; + int nargs; struct gcpro gcpro1; - Lisp_Object val = Qnil; - - GCPRO1 (args); - - { - 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))); - } - - while (!NILP (args)) + + GET_LIST_LENGTH (args, nargs); + + if (nargs & 1) /* Odd number of arguments? */ + Fsignal (Qwrong_number_of_arguments, list2 (Qsetq, make_int (nargs))); + + GCPRO1 (val); + + PROPERTY_LIST_LOOP (tail, symbol, val, args) { - Lisp_Object sym = XCAR (args); - val = Feval (XCAR (XCDR (args))); - Fset (sym, val); - args = XCDR (XCDR (args)); + val = Feval (val); + Fset (symbol, val); } UNGCPRO; @@ -1014,9 +998,18 @@ } -/**********************************************************************/ -/* Defining functions/variables */ -/**********************************************************************/ +/************************************************************************/ +/* Defining functions/variables */ +/************************************************************************/ +static Lisp_Object +define_function (Lisp_Object name, Lisp_Object defn) +{ + if (purify_flag) + defn = Fpurecopy (defn); + Ffset (name, defn); + LOADHIST_ATTACH (name); + return name; +} DEFUN ("defun", Fdefun, 2, UNEVALLED, 0, /* \(defun NAME ARGLIST [DOCSTRING] BODY...): define NAME as a function. @@ -1026,14 +1019,8 @@ (args)) { /* This function can GC */ - Lisp_Object fn_name = XCAR (args); - Lisp_Object defn = Fcons (Qlambda, XCDR (args)); - - if (purify_flag) - defn = Fpurecopy (defn); - Ffset (fn_name, defn); - LOADHIST_ATTACH (fn_name); - return fn_name; + return define_function (XCAR (args), + Fcons (Qlambda, XCDR (args))); } DEFUN ("defmacro", Fdefmacro, 2, UNEVALLED, 0, /* @@ -1047,14 +1034,8 @@ (args)) { /* This function can GC */ - Lisp_Object fn_name = XCAR (args); - Lisp_Object defn = Fcons (Qmacro, Fcons (Qlambda, XCDR (args))); - - if (purify_flag) - defn = Fpurecopy (defn); - Ffset (fn_name, defn); - LOADHIST_ATTACH (fn_name); - return fn_name; + return define_function (XCAR (args), + Fcons (Qmacro, Fcons (Qlambda, XCDR (args)))); } DEFUN ("defvar", Fdefvar, 1, UNEVALLED, 0, /* @@ -1086,7 +1067,13 @@ Lisp_Object val = XCAR (args); if (NILP (Fdefault_boundp (sym))) - Fset_default (sym, Feval (val)); + { + struct gcpro gcpro1; + GCPRO1 (val); + val = Feval (val); + Fset_default (sym, val); + UNGCPRO; + } if (!NILP (args = XCDR (args))) { @@ -1134,9 +1121,14 @@ { /* This function can GC */ Lisp_Object sym = XCAR (args); - Lisp_Object val = XCAR (args = XCDR (args)); - - Fset_default (sym, Feval (val)); + Lisp_Object val = Feval (XCAR (args = XCDR (args))); + struct gcpro gcpro1; + + GCPRO1 (val); + + Fset_default (sym, val); + + UNGCPRO; if (!NILP (args = XCDR (args))) { @@ -1170,21 +1162,20 @@ */ (variable)) { - Lisp_Object documentation; - - 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) + Lisp_Object documentation = Fget (variable, Qvariable_documentation, Qnil); + + return + ((INTP (documentation) && XINT (documentation) < 0) || + + ((STRINGP (documentation)) && + (string_byte (XSTRING (documentation), 0) == '*')) || + + /* If (STRING . INTEGER), a negative integer means a user variable. */ + (CONSP (documentation) && STRINGP (XCAR (documentation)) && INTP (XCDR (documentation)) - && XINT (XCDR (documentation)) < 0) - return Qt; - return Qnil; + && XINT (XCDR (documentation)) < 0)) ? + Qt : Qnil; } DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /* @@ -1265,9 +1256,9 @@ } -/**********************************************************************/ -/* Non-local exits */ -/**********************************************************************/ +/************************************************************************/ +/* Non-local exits */ +/************************************************************************/ DEFUN ("catch", Fcatch, 1, UNEVALLED, 0, /* \(catch TAG BODY...): eval BODY allowing nonlocal exits using `throw'. @@ -1279,13 +1270,9 @@ (args)) { /* This function can GC */ - Lisp_Object tag; - struct gcpro gcpro1; - - GCPRO1 (args); - tag = Feval (XCAR (args)); - UNGCPRO; - return internal_catch (tag, Fprogn, XCDR (args), 0); + Lisp_Object tag = Feval (XCAR (args)); + Lisp_Object body = XCDR (args); + return internal_catch (tag, Fprogn, body, 0); } /* Set up a catch, then call C function FUNC on argument ARG. @@ -1311,7 +1298,7 @@ c.handlerlist = handlerlist; #endif c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = specpdl_depth_counter; + c.pdlcount = specpdl_depth(); #if 0 /* FSFmacs */ c.poll_suppress_count = async_timer_suppress_count; #endif @@ -1396,7 +1383,9 @@ backtrace_list = c->backlist; lisp_eval_depth = c->lisp_eval_depth; +#if 0 /* no longer used */ throw_level = 0; +#endif LONGJMP (c->jmp, 1); } @@ -1490,18 +1479,16 @@ (args)) { /* This function can GC */ - Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fprogn, XCDR (args)); - val = Feval (XCAR (args)); - return unbind_to (speccount, val); + return unbind_to (speccount, Feval (XCAR (args))); } -/**********************************************************************/ -/* Signalling and trapping errors */ -/**********************************************************************/ +/************************************************************************/ +/* Signalling and trapping errors */ +/************************************************************************/ static Lisp_Object condition_bind_unwind (Lisp_Object loser) @@ -1599,7 +1586,7 @@ Lisp_Object (*hfun) (Lisp_Object val, Lisp_Object harg), Lisp_Object harg) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); struct catchtag c; struct gcpro gcpro1; @@ -1622,7 +1609,7 @@ c.handlerlist = handlerlist; #endif c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = specpdl_depth_counter; + c.pdlcount = specpdl_depth(); #if 0 /* FSFmacs */ c.poll_suppress_count = async_timer_suppress_count; #endif @@ -1674,17 +1661,18 @@ 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 */ - - speccount = specpdl_depth_counter; + return Fprogn (Fcdr (val)); /* tail call */ + + speccount = specpdl_depth(); specbind (var, Fcar (val)); val = Fprogn (Fcdr (val)); return unbind_to (speccount, val); @@ -1698,30 +1686,45 @@ condition_case_3 (Lisp_Object bodyform, Lisp_Object var, Lisp_Object handlers) { /* This function can GC */ - Lisp_Object val; + Lisp_Object handler; + + EXTERNAL_LIST_LOOP_2 (handler, handlers) + { + 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); - for (val = handlers; ! NILP (val); val = Fcdr (val)) - { - Lisp_Object tem; - tem = Fcar (val); - if ((!NILP (tem)) - && (!CONSP (tem) - || (!SYMBOLP (XCAR (tem)) && !CONSP (XCAR (tem))))) - signal_simple_error ("Invalid condition handler", tem); - } - return condition_case_1 (handlers, - Feval, bodyform, - run_condition_case_handlers, - var); + Feval, bodyform, + run_condition_case_handlers, + var); } DEFUN ("condition-case", Fcondition_case, 2, UNEVALLED, 0, /* Regain control when an error is signalled. Usage looks like (condition-case VAR BODYFORM HANDLERS...). -executes BODYFORM and returns its value if no error happens. +Executes BODYFORM and returns its value if no error happens. Each element of HANDLERS looks like (CONDITION-NAME BODY...) where the BODY is made of Lisp expressions. @@ -1755,9 +1758,10 @@ (args)) { /* This function can GC */ - return condition_case_3 (XCAR (XCDR (args)), - XCAR (args), - XCDR (XCDR (args))); + Lisp_Object var = XCAR (args); + Lisp_Object bodyform = XCAR (XCDR (args)); + Lisp_Object handlers = XCDR (XCDR (args)); + return condition_case_3 (bodyform, var, handlers); } DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /* @@ -1779,20 +1783,19 @@ (int nargs, Lisp_Object *args)) /* Note! Args side-effected! */ { /* This function can GC */ - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; /* #### If there were a way to check that args[0] were a function which accepted one arg, that should be done here ... */ /* (handler-fun . handler-args) */ - tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); + tem = noseeum_cons (list1 (args[0]), Vcondition_handlers); record_unwind_protect (condition_bind_unwind, tem); Vcondition_handlers = tem; /* Caller should have GC-protected args */ - tem = Ffuncall (nargs - 1, args + 1); - return unbind_to (speccount, tem); + return unbind_to (speccount, Ffuncall (nargs - 1, args + 1)); } static int @@ -1802,25 +1805,15 @@ /* (condition-case c # (t c)) catches -all- signals * Use with caution! */ return 1; - else - { - if (SYMBOLP (type)) - { - return !NILP (Fmemq (type, conditions)); - } - else if (CONSP (type)) - { - while (CONSP (type)) - { - if (!NILP (Fmemq (Fcar (type), conditions))) - return 1; - type = XCDR (type); - } - return 0; - } - else - return 0; - } + + if (SYMBOLP (type)) + return !NILP (Fmemq (type, conditions)); + + for (; CONSP (type); type = XCDR (type)) + if (!NILP (Fmemq (XCAR (type), conditions))) + return 1; + + return 0; } static Lisp_Object @@ -1842,7 +1835,9 @@ extern int in_display; -/****************** the workhorse error-signaling function ******************/ +/************************************************************************/ +/* the workhorse error-signaling function */ +/************************************************************************/ /* #### This function has not been synched with FSF. It diverges significantly. */ @@ -2056,9 +2051,11 @@ static Lisp_Object call_with_suspended_errors_1 (Lisp_Object opaque_arg) { + Lisp_Object val; Lisp_Object *kludgy_args = (Lisp_Object *) get_opaque_ptr (opaque_arg); - return primitive_funcall ((lisp_fn_t) get_opaque_ptr (kludgy_args[0]), - XINT (kludgy_args[1]), kludgy_args + 2); + PRIMITIVE_FUNCALL (val, get_opaque_ptr (kludgy_args[0]), + kludgy_args + 2, XINT (kludgy_args[1])); + return val; } static Lisp_Object @@ -2134,9 +2131,13 @@ enabled error-checking. */ if (ERRB_EQ (errb, ERROR_ME)) - return primitive_funcall (fun, nargs, args); - - speccount = specpdl_depth_counter; + { + Lisp_Object val; + PRIMITIVE_FUNCALL (val, fun, args, nargs); + return val; + } + + speccount = specpdl_depth(); if (NILP (class) || NILP (Vcurrent_warning_class)) { /* If we're currently calling for no warnings, then make it so. @@ -2479,9 +2480,53 @@ } -/**********************************************************************/ -/* User commands */ -/**********************************************************************/ +/* Used in core lisp functions for efficiency */ +void +signal_void_function_error (Lisp_Object function) +{ + Fsignal (Qvoid_function, list1 (function)); +} + +static void +signal_invalid_function_error (Lisp_Object function) +{ + Fsignal (Qinvalid_function, list1 (function)); +} + +static void +signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs) +{ + Fsignal (Qwrong_number_of_arguments, list2 (function, make_int (nargs))); +} + +/* Used in list traversal macros for efficiency. */ +void +signal_malformed_list_error (Lisp_Object list) +{ + Fsignal (Qmalformed_list, list1 (list)); +} + +void +signal_malformed_property_list_error (Lisp_Object list) +{ + Fsignal (Qmalformed_property_list, list1 (list)); +} + +void +signal_circular_list_error (Lisp_Object list) +{ + Fsignal (Qcircular_list, list1 (list)); +} + +void +signal_circular_property_list_error (Lisp_Object list) +{ + Fsignal (Qcircular_property_list, list1 (list)); +} + +/************************************************************************/ +/* User commands */ +/************************************************************************/ DEFUN ("commandp", Fcommandp, 1, 1, 0, /* Return t if FUNCTION makes provisions for interactive calling. @@ -2505,35 +2550,32 @@ { Lisp_Object fun = indirect_function (function, 0); - if (UNBOUNDP (fun)) - return Qnil; + if (COMPILED_FUNCTIONP (fun)) + return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; + + /* Lists may represent commands. */ + if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qlambda)) + return Fassq (Qinteractive, Fcdr (Fcdr (fun))); + if (EQ (funcar, Qautoload)) + return Fcar (Fcdr (Fcdr (Fcdr (fun)))); + else + return Qnil; + } /* Emacs primitives are interactive if their DEFUN specifies an interactive spec. */ if (SUBRP (fun)) return XSUBR (fun)->prompt ? Qt : Qnil; - if (COMPILED_FUNCTIONP (fun)) - return XCOMPILED_FUNCTION (fun)->flags.interactivep ? Qt : Qnil; - /* Strings and vectors are keyboard macros. */ if (VECTORP (fun) || STRINGP (fun)) return Qt; - /* Lists may represent commands. */ - if (!CONSP (fun)) - return Qnil; - { - Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - return Fsignal (Qinvalid_function, list1 (fun)); - if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (Fcdr (fun))); - if (EQ (funcar, Qautoload)) - return Fcar (Fcdr (Fcdr (Fcdr (fun)))); - else - return Qnil; - } + /* Everything else (including Qunbound) is not a command. */ + return Qnil; } DEFUN ("command-execute", Fcommand_execute, 1, 3, 0, /* @@ -2570,14 +2612,11 @@ if (CONSP (final) || SUBRP (final) || COMPILED_FUNCTIONP (final)) { -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif backtrace.function = &Qcall_interactively; backtrace.args = &cmd; backtrace.nargs = 1; backtrace.evalargs = 0; - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.debug_on_exit = 0; PUSH_BACKTRACE (backtrace); @@ -2675,9 +2714,9 @@ } -/**********************************************************************/ -/* Autoloading */ -/**********************************************************************/ +/************************************************************************/ +/* Autoloading */ +/************************************************************************/ DEFUN ("autoload", Fautoload, 2, 5, 0, /* Define FUNCTION to autoload from FILE. @@ -2700,10 +2739,11 @@ CHECK_STRING (file); /* If function is defined and not as an autoload, don't override */ - if (!UNBOUNDP (XSYMBOL (function)->function) - && !(CONSP (XSYMBOL (function)->function) - && EQ (XCAR (XSYMBOL (function)->function), Qautoload))) - return Qnil; + { + Lisp_Object f = XSYMBOL (function)->function; + if (!UNBOUNDP (f) && !(CONSP (f) && EQ (XCAR (f), Qautoload))) + return Qnil; + } if (purify_flag) { @@ -2730,7 +2770,7 @@ Vautoload_queue = oldqueue; while (CONSP (queue)) { - first = Fcar (queue); + first = XCAR (queue); second = Fcdr (first); first = Fcar (first); if (NILP (second)) @@ -2747,7 +2787,7 @@ Lisp_Object funname) { /* This function can GC */ - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object fun = funname; struct gcpro gcpro1, gcpro2; @@ -2757,29 +2797,25 @@ /* 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); - - /* 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))); - - queue = Fcdr (queue); - } + for (queue = Vautoload_queue; CONSP (queue); queue = XCDR (queue)) + { + Lisp_Object first = XCAR (queue); + Lisp_Object second = Fcdr (first); + + first = Fcar (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, (XCDR (second))); + } } /* Once loading finishes, don't undo it. */ @@ -2801,14 +2837,12 @@ } -/**********************************************************************/ -/* eval, funcall, apply */ -/**********************************************************************/ +/************************************************************************/ +/* eval, funcall, apply */ +/************************************************************************/ static Lisp_Object funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[]); -static Lisp_Object apply_lambda (Lisp_Object fun, - int nargs, Lisp_Object args); static int in_warnings; static Lisp_Object @@ -2818,51 +2852,6 @@ return Qnil; } -#define AV_0(av) -#define AV_1(av) av[0] -#define AV_2(av) AV_1(av), av[1] -#define AV_3(av) AV_2(av), av[2] -#define AV_4(av) AV_3(av), av[3] -#define AV_5(av) AV_4(av), av[4] -#define AV_6(av) AV_5(av), av[5] -#define AV_7(av) AV_6(av), av[6] -#define AV_8(av) AV_7(av), av[7] - -#define PRIMITIVE_FUNCALL(fn, av, ac) \ -(((Lisp_Object (*)(EXFUN_##ac)) (fn)) (AV_##ac (av))) - -/* If subr's take more than 8 arguments, more cases need to be added - to this switch. (But don't do it - if you really need a SUBR with - more than 8 arguments, use max_args == MANY. - See the DEFUN macro in lisp.h) */ -#define inline_funcall_fn(rv, fn, av, ac) do { \ - switch (ac) { \ - case 0: rv = PRIMITIVE_FUNCALL(fn, av, 0); break; \ - case 1: rv = PRIMITIVE_FUNCALL(fn, av, 1); break; \ - case 2: rv = PRIMITIVE_FUNCALL(fn, av, 2); break; \ - case 3: rv = PRIMITIVE_FUNCALL(fn, av, 3); break; \ - case 4: rv = PRIMITIVE_FUNCALL(fn, av, 4); break; \ - case 5: rv = PRIMITIVE_FUNCALL(fn, av, 5); break; \ - case 6: rv = PRIMITIVE_FUNCALL(fn, av, 6); break; \ - case 7: rv = PRIMITIVE_FUNCALL(fn, av, 7); break; \ - case 8: rv = PRIMITIVE_FUNCALL(fn, av, 8); break; \ - default: abort(); rv = Qnil; break; \ - } \ -} while (0) - -#define inline_funcall_subr(rv, subr, av) do { \ - void (*fn)() = (void (*)()) (subr_function(subr)); \ - inline_funcall_fn (rv, fn, av, subr->max_args); \ -} while (0) - -static Lisp_Object -primitive_funcall (lisp_fn_t fn, int nargs, Lisp_Object args[]) -{ - Lisp_Object rv; - inline_funcall_fn (rv, fn, args, nargs); - return rv; -} - DEFUN ("eval", Feval, 1, 1, 0, /* Evaluate FORM and return its value. */ @@ -2877,7 +2866,7 @@ while (!in_warnings && !NILP (Vpending_warnings)) { struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object this_warning_cons, this_warning, class, level, messij; record_unwind_protect (in_warnings_restore, Qnil); @@ -2905,11 +2894,13 @@ unbind_to (speccount, Qnil); } - if (SYMBOLP (form)) - return Fsymbol_value (form); - if (!CONSP (form)) - return form; + { + if (SYMBOLP (form)) + return Fsymbol_value (form); + else + return form; + } QUIT; if ((consing_since_gc > gc_cons_threshold) || always_gc) @@ -2928,34 +2919,13 @@ 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); - -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif - backtrace.pdlcount = specpdl_depth_counter; + GET_EXTERNAL_LIST_LENGTH (original_args, nargs); + + backtrace.pdlcount = specpdl_depth(); backtrace.function = &original_fun; /* This also protects them from gc */ backtrace.args = &original_args; backtrace.nargs = UNEVALLED; @@ -2970,125 +2940,173 @@ 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 - || (max_args >= 0 && max_args < nargs)) - { - return Fsignal (Qwrong_number_of_arguments, - list2 (fun, make_int (nargs))); - } - - if (max_args == UNEVALLED) + + if (nargs < subr->min_args) + goto wrong_number_of_arguments; + + 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); - UNGCPRO; - return val; - } - - else - { - struct gcpro gcpro1, gcpro2, gcpro3; - - GCPRO3 (args_left, fun, fun); - gcpro3.var = argvals; - gcpro3.nvars = 0; - - for (i = 0; i < nargs; args_left = XCDR (args_left)) - { - argvals[i] = Feval (XCAR (args_left)); - gcpro3.nvars = ++i; - } + val = (((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) + (nargs, args)); UNGCPRO; - - /* i == nargs at this point */ - for (; i < max_args; i++) - argvals[i] = Qnil; - - backtrace.args = argvals; - backtrace.nargs = nargs; - - /* val = funcall_subr (subr, argvals); */ - inline_funcall_subr (val, subr, argvals); - } + } + else + { + wrong_number_of_arguments: + signal_wrong_number_of_arguments_error (fun, nargs); + } } else if (COMPILED_FUNCTIONP (fun)) - val = apply_lambda (fun, nargs, original_args); - else { - Lisp_Object funcar; - - if (!CONSP (fun)) - goto invalid_function; - funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - goto invalid_function; + 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; + backtrace.evalargs = 0; + + val = funcall_compiled_function (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; + + UNGCPRO; + } + else if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qautoload)) { do_autoload (fun, original_fun); goto retry; } - if (EQ (funcar, Qmacro)) - val = Feval (apply1 (XCDR (fun), original_args)); + else if (EQ (funcar, Qmacro)) + { + val = Feval (apply1 (XCDR (fun), original_args)); + } else if (EQ (funcar, Qlambda)) - val = apply_lambda (fun, nargs, original_args); + { + struct gcpro gcpro1; + Lisp_Object *args = alloca_array (Lisp_Object, nargs); + REGISTER Lisp_Object *p = args; + + GCPRO1 (args[0]); + gcpro1.nvars = 0; + + { + REGISTER Lisp_Object arg; + LIST_LOOP_2 (arg, original_args) + { + *p++ = Feval (arg); + gcpro1.nvars++; + } + } + + UNGCPRO; + + backtrace.args = args; /* this also GCPROs `args' */ + backtrace.nargs = nargs; + backtrace.evalargs = 0; + + val = funcall_lambda (fun, nargs, args); + + /* Do the debug-on-exit now, while args is still GCPROed. */ + if (backtrace.debug_on_exit) + val = do_debug_on_exit (val); + /* Don't do it again when we return to eval. */ + backtrace.debug_on_exit = 0; + } else { - invalid_function: - return Fsignal (Qinvalid_function, list1 (fun)); + goto invalid_function; } } + else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */ + { + invalid_function: + signal_invalid_function_error (fun); + } lisp_eval_depth--; if (backtrace.debug_on_exit) @@ -3098,15 +3116,18 @@ } -Lisp_Object -funcall_recording_as (Lisp_Object recorded_as, int nargs, - Lisp_Object *args) +DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* +Call first argument as a function, passing the remaining arguments to it. +Thus, (funcall 'cons 'x 'y) returns (x . y). +*/ + (int nargs, Lisp_Object *args)) { /* This function can GC */ Lisp_Object fun; Lisp_Object val; struct backtrace backtrace; - REGISTER int i; + int fun_nargs = nargs - 1; + Lisp_Object *fun_args = args + 1; QUIT; if ((consing_since_gc > gc_cons_threshold) || always_gc) @@ -3121,16 +3142,10 @@ error ("Lisp nesting exceeds `max-lisp-eval-depth'"); } - /* Count number of arguments to function */ - nargs = nargs - 1; - -#ifdef EMACS_BTL - backtrace.id_number = 0; -#endif - backtrace.pdlcount = specpdl_depth_counter; + backtrace.pdlcount = specpdl_depth(); backtrace.function = &args[0]; - backtrace.args = &args[1]; - backtrace.nargs = nargs; + backtrace.args = fun_args; + backtrace.nargs = fun_nargs; backtrace.evalargs = 0; backtrace.debug_on_exit = 0; PUSH_BACKTRACE (backtrace); @@ -3142,86 +3157,97 @@ 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; - - if (max_args == UNEVALLED) - return Fsignal (Qinvalid_function, list1 (fun)); - - if (nargs < subr->min_args - || (max_args >= 0 && max_args < nargs)) + Lisp_Object spacious_args[SUBR_MAX_ARGS]; + + if (fun_nargs < subr->min_args) + goto wrong_number_of_arguments; + + 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); } - - if (max_args == MANY) + else if (fun_nargs < max_args) { - val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr))) - (nargs, args + 1); - } - - else if (max_args > nargs) - { - Lisp_Object argvals[SUBR_MAX_ARGS]; + Lisp_Object *p = spacious_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); + 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))) + (fun_nargs, fun_args); + } + else if (max_args == UNEVALLED) /* Can't funcall a special form */ + { + goto invalid_function; } else - /* val = funcall_subr (subr, args + 1); */ - inline_funcall_subr (val, subr, (&args[1])); + { + wrong_number_of_arguments: + signal_wrong_number_of_arguments_error (fun, fun_nargs); + } } else if (COMPILED_FUNCTIONP (fun)) - val = funcall_lambda (fun, nargs, args + 1); - else if (!CONSP (fun)) { - invalid_function: - return Fsignal (Qinvalid_function, list1 (fun)); + val = funcall_compiled_function (fun, fun_nargs, fun_args); } - else + else if (CONSP (fun)) { - /* `fun' is a Lisp_Cons so XCAR is safe */ Lisp_Object funcar = XCAR (fun); - if (!SYMBOLP (funcar)) - goto invalid_function; if (EQ (funcar, Qlambda)) - val = funcall_lambda (fun, nargs, args + 1); + { + val = funcall_lambda (fun, fun_nargs, fun_args); + } else if (EQ (funcar, Qautoload)) { do_autoload (fun, args[0]); goto retry; } - else + else /* Can't funcall a macro */ { - goto invalid_function; + goto invalid_function; } } + else if (UNBOUNDP (fun)) + { + signal_void_function_error (args[0]); + } + else + { + invalid_function: + signal_invalid_function_error (fun); + } + lisp_eval_depth--; if (backtrace.debug_on_exit) val = do_debug_on_exit (val); @@ -3229,25 +3255,30 @@ return val; } -DEFUN ("funcall", Ffuncall, 1, MANY, 0, /* -Call first argument as a function, passing remaining arguments to it. -Thus, (funcall 'cons 'x 'y) returns (x . y). +DEFUN ("functionp", Ffunctionp, 1, 1, 0, /* +Return t if OBJECT can be called as a function, else nil. +A function is an object that can be applied to arguments, +using for example `funcall' or `apply'. */ - (int nargs, Lisp_Object *args)) + (object)) { - return funcall_recording_as (args[0], nargs, args); + if (SYMBOLP (object)) + object = indirect_function (object, 0); + + return + (SUBRP (object) || + COMPILED_FUNCTIONP (object) || + (CONSP (object) && + (EQ (XCAR (object), Qlambda) || + EQ (XCAR (object), Qautoload)))) + ? Qt : Qnil; } -DEFUN ("function-min-args", Ffunction_min_args, 1, 1, 0, /* -Return the number of arguments a function may be called with. The -function may be any form that can be passed to `funcall', any special -form, or any macro. -*/ - (function)) +static Lisp_Object +function_argcount (Lisp_Object function, int function_min_args_p) { Lisp_Object orig_function = function; Lisp_Object arglist; - int argcount; retry: @@ -3255,148 +3286,108 @@ 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); - } - - 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. -*/ - (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 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-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)) +{ + return function_argcount (function, 1); +} + +DEFUN ("function-max-args", Ffunction_max_args, 1, 1, 0, /* +Return the number of arguments a function may be called with. +The function may be any form that can be passed to `funcall', +any special form, or any macro. +If the function takes an arbitrary number of arguments or is +a built-in special form, nil is returned. +*/ + (function)) +{ + return function_argcount (function, 0); } DEFUN ("apply", Fapply, 2, MANY, 0, /* -Call FUNCTION with our remaining args, using our last arg as list of args. +Call FUNCTION with the remaining args, using the last arg as a list of args. Thus, (apply '+ 1 2 '(3 4)) returns 10. */ (int nargs, Lisp_Object *args)) { /* This function can GC */ Lisp_Object fun = args[0]; - Lisp_Object spread_arg = args [nargs - 1], p; + Lisp_Object spread_arg = args [nargs - 1]; int numargs; int funcall_nargs; - CHECK_LIST (spread_arg); - - /* - * Formerly we used a call to Flength here, but that is slow and - * wasteful due to type checking, stack push/pop and initialization. - * We know we're dealing with a cons, so open code it for speed. - * - * We call QUIT in the loop so that a circular arg list won't lock - * up the editor. - */ - for (numargs = 0, p = spread_arg ; CONSP (p) ; p = XCDR (p)) - { - numargs++; - QUIT; - } - if (! NILP (p)) - signal_simple_error ("Argument list must be nil-terminated", spread_arg); + GET_EXTERNAL_LIST_LENGTH (spread_arg, numargs); if (numargs == 0) /* (apply foo 0 1 '()) */ @@ -3415,14 +3406,10 @@ if (SYMBOLP (fun)) fun = indirect_function (fun, 0); - if (UNBOUNDP (fun)) + + if (SUBRP (fun)) { - /* Let funcall get the error */ - fun = args[0]; - } - else if (SUBRP (fun)) - { - struct Lisp_Subr *subr = XSUBR (fun); + Lisp_Subr *subr = XSUBR (fun); int max_args = subr->max_args; if (numargs < subr->min_args @@ -3437,6 +3424,12 @@ funcall_nargs += (max_args - numargs); } } + else if (UNBOUNDP (fun)) + { + /* Let funcall get the error */ + fun = args[0]; + } + { REGISTER int i; Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs); @@ -3465,145 +3458,66 @@ } -/* 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); - - GCPRO3 (*arg_vector, unevalled_args, fun); - gcpro1.nvars = 0; - - 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; - - 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; -} - -/* 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. */ - -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; - - if (CONSP (fun)) - syms_left = Fcar (XCDR (fun)); - else if (COMPILED_FUNCTIONP (fun)) - syms_left = XCOMPILED_FUNCTION (fun)->arglist; - else abort (); - - 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); - } + Lisp_Object symbol, arglist, body, tail; + int speccount = specpdl_depth(); + REGISTER int i = 0; + + tail = XCDR (fun); + + if (!CONSP (tail)) + goto invalid_function; + + arglist = XCAR (tail); + body = XCDR (tail); + + { + 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 (i < nargs) - 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); + goto wrong_number_of_arguments; + + return unbind_to (speccount, Fprogn (body)); + + wrong_number_of_arguments: + return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs))); + + invalid_function: + return Fsignal (Qinvalid_function, list1 (fun)); } + -/**********************************************************************/ -/* Run hook variables in various ways. */ -/**********************************************************************/ +/************************************************************************/ +/* Run hook variables in various ways. */ +/************************************************************************/ DEFUN ("run-hooks", Frun_hooks, 1, MANY, 0, /* Run each hook in HOOKS. Major mode functions use this. @@ -3691,7 +3605,6 @@ enum run_hooks_condition cond) { Lisp_Object sym, val, ret; - struct gcpro gcpro1, gcpro2; if (!initialized || preparing_for_armageddon) /* We need to bail out of here pronto. */ @@ -3714,6 +3627,7 @@ } else { + struct gcpro gcpro1, gcpro2; GCPRO2 (sym, val); for (; @@ -3784,11 +3698,10 @@ Lisp_Object run_hook_list_with_args (Lisp_Object funlist, int nargs, Lisp_Object *args) { - Lisp_Object sym; + Lisp_Object sym = args[0]; Lisp_Object val; struct gcpro gcpro1, gcpro2; - sym = args[0]; GCPRO2 (sym, val); for (val = funlist; CONSP (val); val = XCDR (val)) @@ -3874,9 +3787,9 @@ } -/**********************************************************************/ -/* Front-ends to eval, funcall, apply */ -/**********************************************************************/ +/************************************************************************/ +/* Front-ends to eval, funcall, apply */ +/************************************************************************/ /* Apply fn to arg */ Lisp_Object @@ -4066,7 +3979,7 @@ else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call0 (fn); @@ -4084,7 +3997,7 @@ else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call1 (fn, arg0); @@ -4102,7 +4015,7 @@ else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call2 (fn, arg0, arg1); @@ -4120,7 +4033,7 @@ else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call3 (fn, arg0, arg1, arg2); @@ -4139,7 +4052,7 @@ else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = call4 (fn, arg0, arg1, arg2, arg3); @@ -4156,7 +4069,7 @@ else { Lisp_Object val; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); record_unwind_protect (Fset_buffer, Fcurrent_buffer ()); set_buffer_internal (buf); val = Feval (form); @@ -4166,7 +4079,9 @@ } -/***** Error-catching front-ends to eval, funcall, apply */ +/************************************************************************/ +/* Error-catching front-ends to eval, funcall, apply */ +/************************************************************************/ /* Call function fn on no arguments, with condition handler */ Lisp_Object @@ -4279,7 +4194,7 @@ eval_in_buffer_trapping_errors (CONST char *warning_string, struct buffer *buf, Lisp_Object form) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object buffer; Lisp_Object cons; @@ -4329,7 +4244,7 @@ if (NILP (tem) || UNBOUNDP (tem)) return Qnil; - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (Qinhibit_quit, Qt); opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil); @@ -4353,7 +4268,7 @@ Lisp_Object hook_symbol, int allow_quit) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; struct gcpro gcpro1; @@ -4410,7 +4325,7 @@ } GCPRO2 (opaque, function); - speccount = specpdl_depth_counter; + speccount = specpdl_depth(); specbind (Qinhibit_quit, Qt); /* gc_currently_forbidden = 1; Currently no reason to do this; */ @@ -4445,7 +4360,7 @@ call1_trapping_errors (CONST char *warning_string, Lisp_Object function, Lisp_Object object) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; Lisp_Object opaque = Qnil; @@ -4482,7 +4397,7 @@ call2_trapping_errors (CONST char *warning_string, Lisp_Object function, Lisp_Object object1, Lisp_Object object2) { - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); Lisp_Object tem; Lisp_Object cons = Qnil; Lisp_Object opaque = Qnil; @@ -4515,33 +4430,40 @@ } -/**********************************************************************/ -/* The special binding stack */ -/**********************************************************************/ +/************************************************************************/ +/* The special binding stack */ +/* Most C code should simply use specbind() and unbind_to(). */ +/* When performance is critical, use the macros in backtrace.h. */ +/************************************************************************/ #define min_max_specpdl_size 400 -static void -grow_specpdl (void) +void +grow_specpdl (size_t reserved) { - if (specpdl_size >= max_specpdl_size) + size_t size_needed = specpdl_depth() + reserved; + if (size_needed >= max_specpdl_size) { if (max_specpdl_size < min_max_specpdl_size) max_specpdl_size = min_max_specpdl_size; - if (specpdl_size >= max_specpdl_size) + if (size_needed >= max_specpdl_size) { - if (!NILP (Vdebug_on_error) || !NILP (Vdebug_on_signal)) + if (!NILP (Vdebug_on_error) || + !NILP (Vdebug_on_signal)) /* Leave room for some specpdl in the debugger. */ - max_specpdl_size = specpdl_size + 100; + max_specpdl_size = size_needed + 100; continuable_error ("Variable binding depth exceeds max-specpdl-size"); } } - specpdl_size *= 2; - if (specpdl_size > max_specpdl_size) - specpdl_size = max_specpdl_size; + while (specpdl_size < size_needed) + { + specpdl_size *= 2; + if (specpdl_size > max_specpdl_size) + specpdl_size = max_specpdl_size; + } XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size); - specpdl_ptr = specpdl + specpdl_depth_counter; + specpdl_ptr = specpdl + specpdl_depth(); } @@ -4620,14 +4542,15 @@ void specbind (Lisp_Object symbol, Lisp_Object value) { - int buffer_local; - - CHECK_SYMBOL (symbol); - - if (specpdl_depth_counter >= specpdl_size) - grow_specpdl (); - - buffer_local = symbol_value_buffer_local_info (symbol, current_buffer); + SPECBIND (symbol, value); +} + +void +specbind_magic (Lisp_Object symbol, Lisp_Object value) +{ + int buffer_local = + symbol_value_buffer_local_info (symbol, current_buffer); + if (buffer_local == 0) { specpdl_ptr->old_value = find_symbol_value (symbol); @@ -4658,8 +4581,7 @@ record_unwind_protect (Lisp_Object (*function) (Lisp_Object arg), Lisp_Object arg) { - if (specpdl_depth_counter >= specpdl_size) - grow_specpdl (); + SPECPDL_RESERVE (1); specpdl_ptr->func = function; specpdl_ptr->symbol = Qnil; specpdl_ptr->old_value = arg; @@ -4669,31 +4591,50 @@ 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) { + UNBIND_TO_GCPRO (count, value); + return value; +} + +/* Don't call this directly. + Only for use by UNBIND_TO* macros in backtrace.h */ +void +unbind_to_hairy (int count) +{ int quitf; - struct gcpro gcpro1; - - GCPRO1 (value); check_quit (); /* make Vquit_flag accurate */ quitf = !NILP (Vquit_flag); Vquit_flag = Qnil; + ++specpdl_ptr; + ++specpdl_depth_counter; + while (specpdl_depth_counter != count) { - Lisp_Object ovalue; --specpdl_ptr; --specpdl_depth_counter; - ovalue = specpdl_ptr->old_value; if (specpdl_ptr->func != 0) /* An unwind-protect */ - (*specpdl_ptr->func) (ovalue); + (*specpdl_ptr->func) (specpdl_ptr->old_value); else - Fset (specpdl_ptr->symbol, ovalue); - + { + /* We checked symbol for validity when we specbound it, + so only need to call Fset if symbol has magic value. */ + struct Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol); + if (!SYMBOL_VALUE_MAGIC_P (sym->value)) + sym->value = specpdl_ptr->old_value; + else + Fset (specpdl_ptr->symbol, specpdl_ptr->old_value); + } + +#if 0 /* martin */ #ifndef EXCEEDINGLY_QUESTIONABLE_CODE /* There should never be anything here for us to remove. If so, it indicates a logic error in Emacs. Catches @@ -4711,21 +4652,12 @@ /* Don't mess with gcprolist, backtrace_list here */ } #endif +#endif } if (quitf) Vquit_flag = Qt; - - UNGCPRO; - - return value; } - -int -specpdl_depth (void) -{ - return specpdl_depth_counter; -} /* Get the value of symbol's global binding, even if that binding is @@ -4767,9 +4699,9 @@ #endif /* 0 */ -/**********************************************************************/ -/* Backtraces */ -/**********************************************************************/ +/************************************************************************/ +/* Backtraces */ +/************************************************************************/ DEFUN ("backtrace-debug", Fbacktrace_debug, 2, 2, 0, /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG. @@ -4832,7 +4764,7 @@ /* This function can GC */ struct backtrace *backlist = backtrace_list; struct catchtag *catches = catchlist; - int speccount = specpdl_depth_counter; + int speccount = specpdl_depth(); int old_nl = print_escape_newlines; int old_pr = print_readably; @@ -4989,9 +4921,9 @@ } -/**********************************************************************/ -/* Warnings */ -/**********************************************************************/ +/************************************************************************/ +/* Warnings */ +/************************************************************************/ void warn_when_safe_lispobj (Lisp_Object class, Lisp_Object level, @@ -5011,7 +4943,7 @@ to make sure that Feval() isn't called, since it might not be safe. An alternative approach is to just pass some non-string type of - Lisp Object to warn_when_safe_lispobj(); `prin1-to-string' will + Lisp_Object to warn_when_safe_lispobj(); `prin1-to-string' will automatically be called when it is safe to do so. */ void @@ -5031,9 +4963,9 @@ -/**********************************************************************/ -/* Initialization */ -/**********************************************************************/ +/************************************************************************/ +/* Initialization */ +/************************************************************************/ void syms_of_eval (void) @@ -5058,10 +4990,13 @@ defsymbol (&Qvalues, "values"); defsymbol (&Qdisplay_warning, "display-warning"); defsymbol (&Qrun_hooks, "run-hooks"); + defsymbol (&Qif, "if"); DEFSUBR (For); DEFSUBR (Fand); DEFSUBR (Fif); + DEFSUBR_MACRO (Fwhen); + DEFSUBR_MACRO (Funless); DEFSUBR (Fcond); DEFSUBR (Fprogn); DEFSUBR (Fprog1); @@ -5091,13 +5026,13 @@ DEFSUBR (Feval); DEFSUBR (Fapply); DEFSUBR (Ffuncall); + DEFSUBR (Ffunctionp); DEFSUBR (Ffunction_min_args); DEFSUBR (Ffunction_max_args); DEFSUBR (Frun_hooks); DEFSUBR (Frun_hook_with_args); DEFSUBR (Frun_hook_with_args_until_success); DEFSUBR (Frun_hook_with_args_until_failure); - DEFSUBR (Ffetch_bytecode); DEFSUBR (Fbacktrace_debug); DEFSUBR (Fbacktrace); DEFSUBR (Fbacktrace_frame); @@ -5249,7 +5184,9 @@ /* XEmacs change: increase these values. */ max_specpdl_size = 3000; max_lisp_eval_depth = 500; +#if 0 /* no longer used */ throw_level = 0; +#endif reinit_eval (); } diff -r 76b7d63099ad -r 8626e4521993 src/event-Xt.c --- a/src/event-Xt.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/event-Xt.c Mon Aug 13 11:07:10 2007 +0200 @@ -31,7 +31,6 @@ #include "blocktype.h" #include "buffer.h" -#include "commands.h" #include "console.h" #include "console-tty.h" #include "events.h" @@ -181,7 +180,7 @@ Display *display = DEVICE_X_DISPLAY (d); struct x_device *xd = DEVICE_X_DATA (d); KeySym *keysym, *keysym_end; - Lisp_Object hashtable; + Lisp_Object hash_table; int key_code_count, keysyms_per_code; if (xd->x_keysym_map) @@ -194,12 +193,12 @@ XGetKeyboardMapping (display, xd->x_keysym_map_min_code, key_code_count, &xd->x_keysym_map_keysyms_per_code); - hashtable = xd->x_keysym_map_hashtable; - if (HASHTABLEP (hashtable)) - Fclrhash (hashtable); + hash_table = xd->x_keysym_map_hash_table; + if (HASH_TABLEP (hash_table)) + Fclrhash (hash_table); else - xd->x_keysym_map_hashtable = hashtable = - make_lisp_hashtable (128, HASHTABLE_NONWEAK, HASHTABLE_EQUAL); + xd->x_keysym_map_hash_table = hash_table = + make_lisp_hash_table (128, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); for (keysym = xd->x_keysym_map, keysyms_per_code = xd->x_keysym_map_keysyms_per_code, @@ -217,8 +216,8 @@ Lisp_Object sym = x_keysym_to_emacs_keysym (keysym[0], 0); if (name) { - Fputhash (build_string (name), Qsans_modifiers, hashtable); - Fputhash (sym, Qsans_modifiers, hashtable); + Fputhash (build_string (name), Qsans_modifiers, hash_table); + Fputhash (sym, Qsans_modifiers, hash_table); } } @@ -229,10 +228,10 @@ { char *name = XKeysymToString (keysym[j]); Lisp_Object sym = x_keysym_to_emacs_keysym (keysym[j], 0); - if (name && NILP (Fgethash (sym, hashtable, Qnil))) + if (name && NILP (Fgethash (sym, hash_table, Qnil))) { - Fputhash (build_string (name), Qt, hashtable); - Fputhash (sym, Qt, hashtable); + Fputhash (build_string (name), Qt, hash_table); + Fputhash (sym, Qt, hash_table); } } } @@ -450,7 +449,7 @@ x_init_modifier_mapping (struct device *d) { struct x_device *xd = DEVICE_X_DATA (d); - xd->x_keysym_map_hashtable = Qnil; + xd->x_keysym_map_hash_table = Qnil; xd->x_keysym_map = NULL; xd->x_modifier_keymap = NULL; x_reset_modifier_mapping (d); @@ -772,7 +771,7 @@ /* simple_p means don't try too hard (ASCII only) */ { KeySym keysym = 0; - + #ifdef HAVE_XIM int len; char buffer[64]; @@ -1136,7 +1135,7 @@ emacs_event->timestamp = DEVICE_X_LAST_SERVER_TIMESTAMP (d); state=DndDragButtons(x_event); - + if (state & ShiftMask) modifiers |= MOD_SHIFT; if (state & ControlMask) modifiers |= MOD_CONTROL; if (state & xd->MetaMask) modifiers |= MOD_META; @@ -1183,7 +1182,7 @@ l_type = Qdragdrop_MIME; l_dndlist = list1 ( list3 ( list1 ( make_string ((Bufbyte *)"text/plain", 10) ), make_string ((Bufbyte *)"8bit", 4), - make_ext_string ((Extbyte *)data, + make_ext_string ((Extbyte *)data, strlen((char *)data), FORMAT_CTEXT) ) ); break; @@ -1205,7 +1204,7 @@ case DndLink: case DndExe: { - char *hurl = dnd_url_hexify_string (data, "file:"); + char *hurl = dnd_url_hexify_string ((char *) data, "file:"); l_dndlist = list1 ( make_string ((Bufbyte *)hurl, strlen (hurl)) ); @@ -1217,7 +1216,7 @@ case DndURL: /* as it is a real URL it should already be escaped and escaping again will break them (cause % is unsave) */ - l_dndlist = list1 ( make_ext_string ((Extbyte *)data, + l_dndlist = list1 ( make_ext_string ((Extbyte *)data, strlen ((char *)data), FORMAT_FILENAME) ); l_type = Qdragdrop_URL; @@ -1595,7 +1594,7 @@ handle_client_message (f, event); break; - case VisibilityNotify: /* window visiblity has changed */ + case VisibilityNotify: /* window visibility has changed */ if (event->xvisibility.window == XtWindow (FRAME_X_SHELL_WIDGET (f))) { FRAME_X_TOTALLY_VISIBLE_P (f) = @@ -1694,7 +1693,7 @@ struct Xt_timeout *timeout, *t2; timeout = NULL; - + /* Find the timeout on the list of pending ones, if it's still there. */ if (pending_timeouts) { @@ -2897,18 +2896,18 @@ init_what_input_once (); Xt_event_stream = xnew (struct event_stream); - Xt_event_stream->event_pending_p = emacs_Xt_event_pending_p; - Xt_event_stream->next_event_cb = emacs_Xt_next_event; - Xt_event_stream->handle_magic_event_cb= emacs_Xt_handle_magic_event; - Xt_event_stream->add_timeout_cb = emacs_Xt_add_timeout; - Xt_event_stream->remove_timeout_cb = emacs_Xt_remove_timeout; - Xt_event_stream->select_console_cb = emacs_Xt_select_console; - Xt_event_stream->unselect_console_cb = emacs_Xt_unselect_console; - Xt_event_stream->select_process_cb = emacs_Xt_select_process; - Xt_event_stream->unselect_process_cb = emacs_Xt_unselect_process; - Xt_event_stream->quit_p_cb = emacs_Xt_quit_p; - Xt_event_stream->create_stream_pair_cb= emacs_Xt_create_stream_pair; - Xt_event_stream->delete_stream_pair_cb= emacs_Xt_delete_stream_pair; + Xt_event_stream->event_pending_p = emacs_Xt_event_pending_p; + Xt_event_stream->next_event_cb = emacs_Xt_next_event; + Xt_event_stream->handle_magic_event_cb = emacs_Xt_handle_magic_event; + Xt_event_stream->add_timeout_cb = emacs_Xt_add_timeout; + Xt_event_stream->remove_timeout_cb = emacs_Xt_remove_timeout; + Xt_event_stream->select_console_cb = emacs_Xt_select_console; + Xt_event_stream->unselect_console_cb = emacs_Xt_unselect_console; + Xt_event_stream->select_process_cb = emacs_Xt_select_process; + Xt_event_stream->unselect_process_cb = emacs_Xt_unselect_process; + Xt_event_stream->quit_p_cb = emacs_Xt_quit_p; + Xt_event_stream->create_stream_pair_cb = emacs_Xt_create_stream_pair; + Xt_event_stream->delete_stream_pair_cb = emacs_Xt_delete_stream_pair; DEFVAR_BOOL ("modifier-keys-are-sticky", &modifier_keys_are_sticky /* *Non-nil makes modifier keys sticky. diff -r 76b7d63099ad -r 8626e4521993 src/event-msw.c --- a/src/event-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/event-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -155,7 +155,7 @@ /* This structure is allocated by the main thread, and is deallocated in the thread upon exit. There are situations when a thread remains blocked for a long time, much longer than the lstream - exists. For exmaple, "start notepad" command is issued from the + exists. For example, "start notepad" command is issued from the shell, then the shell is closed by C-c C-d. Although the shell process exits, its output pipe will not get closed until the notepad process exits also, because it inherits the pipe form the @@ -194,7 +194,7 @@ sizeof (struct ntpipe_slurp_stream)); /* This function is thread-safe, and is called from either thread - context. It serializes freeing shared dtata structure */ + context. It serializes freeing shared data structure */ static void slurper_free_shared_data_maybe (struct ntpipe_slurp_stream_shared_data* s) { @@ -268,7 +268,7 @@ if (s->die_p) break; - /* Block until the client finishes with retireving the rest of + /* Block until the client finishes with retrieving the rest of pipe data */ WaitForSingleObject (s->hev_thread, INFINITE); } @@ -619,7 +619,7 @@ OVERLAPPED ov; /* Overlapped I/O structure */ void* buffer; /* Buffer. Allocated for input stream only */ unsigned int bufsize; /* Number of bytes last read */ - unsigned int bufpos; /* Psition in buffer for next fetch */ + unsigned int bufpos; /* Position in buffer for next fetch */ unsigned int error_p :1; /* I/O Error seen */ unsigned int eof_p :1; /* EOF Error seen */ unsigned int pending_p :1; /* There is a pending I/O operation */ @@ -1168,7 +1168,7 @@ * neither are waitable handles checked. The function pumps * thus only dispatch events already queued, as well as those * resulted in dispatching thereof. This is done by setting - * module local variable mswidows_in_modal_loop to nonzero. + * module local variable mswindows_in_modal_loop to nonzero. * * Return value is Qt if no errors was trapped, or Qunbound if * there was an error. @@ -1186,7 +1186,7 @@ * If the value of mswindows_error_caught_in_modal_loop is not * nil already upon entry, the function just returns non-nil. * This situation means that a new event has been queued while - * cancleng mode. The event will be dequeued on the next regular + * in cancel mode. The event will be dequeued on the next regular * call of next-event; the pump is off since error is caught. * The caller must *unconditionally* cancel modal loop if the * value returned by this function is nil. Otherwise, everything @@ -1220,10 +1220,10 @@ } /* - * This is a special flavour of the mswindows_need_event function, + * This is a special flavor of the mswindows_need_event function, * used while in event pump. Actually, there is only kind of events * allowed while in event pump: a timer. An attempt to fetch any - * other event leads to a dealock, as there's no source of user input + * other event leads to a deadlock, as there's no source of user input * ('cause event pump mirrors windows modal loop, which is a sole * owner of thread message queue). * @@ -1367,7 +1367,7 @@ { if (errno != EINTR) { - /* something bad happended */ + /* something bad happened */ assert(0); } } @@ -1401,7 +1401,7 @@ else { int ix = active - WAIT_OBJECT_0; - /* First, try to find which process' ouptut has signaled */ + /* First, try to find which process' output has signaled */ struct Lisp_Process *p = get_process_from_usid (HANDLE_TO_USID (mswindows_waitable_handles[ix])); if (p != NULL) @@ -1412,7 +1412,7 @@ else { /* None. This means that the process handle itself has signaled. - Remove the handle from the wait vector, and make status_ntoify + Remove the handle from the wait vector, and make status_notify note the exited process */ mswindows_waitable_handles [ix] = mswindows_waitable_handles [--mswindows_waitable_count]; @@ -1576,7 +1576,7 @@ LRESULT WINAPI mswindows_wnd_proc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam) { - /* Note: Remember to initialise emacs_event and event before use. + /* Note: Remember to initialize emacs_event and event before use. This code calls code that can GC. You must GCPRO before calling such code. */ Lisp_Object emacs_event = Qnil; Lisp_Object fobj = Qnil; @@ -1860,13 +1860,13 @@ break; case WM_MOUSEMOVE: - /* Optimization: don't report mouse movement while size is changind */ + /* Optimization: don't report mouse movement while size is changing */ msframe = FRAME_MSWINDOWS_DATA (XFRAME (mswindows_find_frame (hwnd))); if (!msframe->sizing) { /* When waiting for the second mouse button to finish button2 emulation, and have moved too far, just pretend - as if timer has expired. This impoves drag-select feedback */ + as if timer has expired. This improves drag-select feedback */ if ((msframe->button2_need_lbutton || msframe->button2_need_rbutton) && !mswindows_button2_near_enough (msframe->last_click_point, MAKEPOINTS (lParam))) @@ -2802,7 +2802,7 @@ DEFVAR_INT ("mswindows-mouse-button-max-skew-x", &mswindows_mouse_button_max_skew_x /* *Maximum horizontal distance in pixels between points in which left and -right button clicks occured for them to be translated into single +right button clicks occurred for them to be translated into single middle button event. Clicks must occur in time not longer than defined by the variable `mswindows-mouse-button-tolerance'. If negative or zero, currently set system default is used instead. @@ -2810,7 +2810,7 @@ DEFVAR_INT ("mswindows-mouse-button-max-skew-y", &mswindows_mouse_button_max_skew_y /* *Maximum vertical distance in pixels between points in which left and -right button clicks occured for them to be translated into single +right button clicks occurred for them to be translated into single middle button event. Clicks must occur in time not longer than defined by the variable `mswindows-mouse-button-tolerance'. If negative or zero, currently set system default is used instead. diff -r 76b7d63099ad -r 8626e4521993 src/event-stream.c --- a/src/event-stream.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/event-stream.c Mon Aug 13 11:07:10 2007 +0200 @@ -47,9 +47,9 @@ sequence, without disturbing the key sequence composition, or the command builder structure representing it. - Someone should rethink univeral-argument and figure out how an + Someone should rethink universal-argument and figure out how an arbitrary command can influence the next command (universal-argument - or univeral-coding-system-argument) or the next key (hyperify). + or universal-coding-system-argument) or the next key (hyperify). Both C-h and Help in the middle of a key sequence should trigger prefix-help-command. help-char is stupid. Maybe we need @@ -249,7 +249,7 @@ /* whether menu accelerators are enabled */ Lisp_Object Vmenu_accelerator_enabled; -/* keymap for auxillary menu accelerator functions */ +/* keymap for auxiliary menu accelerator functions */ Lisp_Object Vmenu_accelerator_map; Lisp_Object Qmenu_force; @@ -392,12 +392,12 @@ mark_command_builder (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct command_builder *builder = XCOMMAND_BUILDER (obj); - (markobj) (builder->prefix_events); - (markobj) (builder->current_events); - (markobj) (builder->most_current_event); - (markobj) (builder->last_non_munged_event); - (markobj) (builder->munge_me[0].first_mungeable_event); - (markobj) (builder->munge_me[1].first_mungeable_event); + markobj (builder->prefix_events); + markobj (builder->current_events); + markobj (builder->most_current_event); + markobj (builder->last_non_munged_event); + markobj (builder->munge_me[0].first_mungeable_event); + markobj (builder->munge_me[1].first_mungeable_event); return builder->console; } @@ -781,9 +781,9 @@ if (XEVENT_TYPE (event) != key_press_event) return; - if (!HASHTABLEP (Vkeyboard_translate_table)) + if (!HASH_TABLEP (Vkeyboard_translate_table)) return; - if (EQ (Fhashtable_fullness (Vkeyboard_translate_table), Qzero)) + if (EQ (Fhash_table_count (Vkeyboard_translate_table), Qzero)) return; c = event_to_character (XEVENT (event), 0, 0, 0); @@ -896,7 +896,7 @@ help = Feval (Vhelp_form); if (STRINGP (help)) - internal_with_output_to_temp_buffer ("*Help*", + internal_with_output_to_temp_buffer (build_string ("*Help*"), print_help, help, Qnil); Fnext_command_event (event, Qnil); /* Remove the help from the frame */ @@ -1129,7 +1129,7 @@ mark_timeout (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct timeout *tm = (struct timeout *) XOPAQUE_DATA (obj); - (markobj) (tm->function); + markobj (tm->function); return tm->object; } @@ -1813,7 +1813,7 @@ * get here and have it be non-nil. */ if (FRAMEP (DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d))) - old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d); + old_frame = DEVICE_FRAME_THAT_OUGHT_TO_HAVE_FOCUS (d); else if (FRAMEP (DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d))) old_frame = DEVICE_FRAME_WITH_FOCUS_FOR_HOOKS (d); @@ -2324,7 +2324,6 @@ XCAR (XCDR (XCDR (Vlast_command_event_time))) = make_int (EMACS_USECS (t)); } - /* If this key came from the keyboard or from a keyboard macro, then it goes into the recent-keys and this-command-keys vectors. If this key came from the keyboard, and we're defining a keyboard @@ -2370,7 +2369,7 @@ The event returned will be a keyboard, mouse press, or mouse release event. If there are non-command events available (mouse motion, sub-process output, etc) then these will be executed (with `dispatch-event') and discarded. This -function is provided as a convenience; it is rougly equivalent to the lisp code +function is provided as a convenience; it is roughly equivalent to the lisp code (while (progn (next-event event prompt) @@ -2510,7 +2509,7 @@ All of these routines install timeouts, so we clear the installed timeout as well. - Note: It's very easy to break the desired behaviours of these + Note: It's very easy to break the desired behaviors of these 3 routines. If you make any changes to anything in this area, run the regression tests at the bottom of the file. -- dmoore */ @@ -2774,7 +2773,7 @@ if (noninteractive || !NILP (Vexecuting_macro)) return Qnil; - /* Recusive call from a filter function or timeout handler. */ + /* Recursive call from a filter function or timeout handler. */ if (!NILP(recursive_sit_for)) { if (!event_stream_event_pending_p (1) && NILP (nodisplay)) @@ -4002,7 +4001,7 @@ /* Vthis_command_keys having value Qnil means that the next time push_this_command_keys is called, it should start over. The times at which the command-keys are reset - (instead of merely being augmented) are pretty conterintuitive. + (instead of merely being augmented) are pretty counterintuitive. (More specifically: -- We do not reset this-command-keys when we finish reading a @@ -4353,7 +4352,7 @@ ; else #endif - if (!NILP (con->prefix_arg)) + if (!NILP (con->prefix_arg)) { /* Commands that set the prefix arg don't update last-command, don't reset the echoing state, and don't go into keyboard macros unless @@ -4969,16 +4968,6 @@ void vars_of_event_stream (void) { -#ifdef HAVE_X_WINDOWS - vars_of_event_Xt (); -#endif -#if defined(HAVE_TTY) && (defined (DEBUG_TTY_EVENT_STREAM) || !defined (HAVE_X_WINDOWS)) - vars_of_event_tty (); -#endif -#ifdef HAVE_MS_WINDOWS - vars_of_event_mswindows (); -#endif - recent_keys_ring_index = 0; recent_keys_ring_size = 100; Vrecent_keys_ring = Qnil; @@ -5340,7 +5329,8 @@ void complex_vars_of_event_stream (void) { - Vkeyboard_translate_table = Fmake_hashtable (make_int (100), Qnil); + Vkeyboard_translate_table = + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); DEFVAR_LISP ("menu-accelerator-map", &Vmenu_accelerator_map /* Keymap for use when the menubar is active. @@ -5464,7 +5454,7 @@ (tst)^Jabc^G ==> ((quit) 97) with no signal, and "bc" inserted in buffer ; with sit-for only do the 2nd test. -; Do all 3 tests with (accept-proccess-output nil 20) +; Do all 3 tests with (accept-process-output nil 20) Do this: (setq enable-recursive-minibuffers t diff -r 76b7d63099ad -r 8626e4521993 src/events.c --- a/src/events.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/events.c Mon Aug 13 11:07:10 2007 +0200 @@ -110,22 +110,22 @@ switch (event->event_type) { case key_press_event: - ((markobj) (event->event.key.keysym)); + markobj (event->event.key.keysym); break; case process_event: - ((markobj) (event->event.process.process)); + markobj (event->event.process.process); break; case timeout_event: - ((markobj) (event->event.timeout.function)); - ((markobj) (event->event.timeout.object)); + markobj (event->event.timeout.function); + markobj (event->event.timeout.object); break; case eval_event: case misc_user_event: - ((markobj) (event->event.eval.function)); - ((markobj) (event->event.eval.object)); + markobj (event->event.eval.function); + markobj (event->event.eval.object); break; case magic_eval_event: - ((markobj) (event->event.magic_eval.object)); + markobj (event->event.magic_eval.object); break; case button_press_event: case button_release_event: @@ -137,7 +137,7 @@ default: abort (); } - ((markobj) (event->channel)); + markobj (event->channel); return event->next; } @@ -154,7 +154,7 @@ print_event (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { if (print_readably) - error ("printing unreadable object #"); + error ("Printing unreadable object #"); switch (XEVENT (obj)->event_type) { @@ -219,16 +219,18 @@ } static int -event_equal (Lisp_Object o1, Lisp_Object o2, int depth) +event_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Event *e1 = XEVENT (o1); - struct Lisp_Event *e2 = XEVENT (o2); + struct Lisp_Event *e1 = XEVENT (obj1); + struct Lisp_Event *e2 = XEVENT (obj2); if (e1->event_type != e2->event_type) return 0; if (!EQ (e1->channel, e2->channel)) return 0; /* if (e1->timestamp != e2->timestamp) return 0; */ switch (e1->event_type) { + default: abort (); + case process_event: return EQ (e1->event.process.process, e2->event.process.process); @@ -284,14 +286,14 @@ #endif #ifdef HAVE_TTY if (CONSOLE_TTY_P (con)) - return (e1->event.magic.underlying_tty_event == - e2->event.magic.underlying_tty_event); + return (e1->event.magic.underlying_tty_event == + e2->event.magic.underlying_tty_event); #endif #ifdef HAVE_MS_WINDOWS if (CONSOLE_MSWINDOWS_P (con)) - return (!memcmp(&e1->event.magic.underlying_mswindows_event, - &e2->event.magic.underlying_mswindows_event, - sizeof(union magic_data))); + return (!memcmp(&e1->event.magic.underlying_mswindows_event, + &e2->event.magic.underlying_mswindows_event, + sizeof(union magic_data))); #endif return 1; /* not reached */ } @@ -299,10 +301,6 @@ case empty_event: /* Empty and deallocated events are equal. */ case dead_event: return 1; - - default: - abort (); - return 0; /* not reached; warning suppression */ } } @@ -512,45 +510,45 @@ } 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) - { - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - } 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); + + 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; + } } 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) + EXTERNAL_LIST_LOOP_2 (sym, value) { - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - } - - EXTERNAL_LIST_LOOP (modtail, value) - { - Lisp_Object sym = XCAR (modtail); - if (EQ (sym, Qcontrol)) modifiers |= MOD_CONTROL; + if (EQ (sym, Qcontrol)) modifiers |= MOD_CONTROL; else if (EQ (sym, Qmeta)) modifiers |= MOD_META; else if (EQ (sym, Qsuper)) modifiers |= MOD_SUPER; else if (EQ (sym, Qhyper)) modifiers |= MOD_HYPER; @@ -560,42 +558,61 @@ else signal_simple_error ("Invalid key modifier", sym); } - if (e->event_type == key_press_event) - e->event.key.modifiers = modifiers; - else if (e->event_type == button_press_event - || e->event_type == button_release_event) - e->event.button.modifiers = modifiers; - else if (e->event_type == pointer_motion_event) - e->event.motion.modifiers = modifiers; - else /* misc_user_event */ - e->event.misc.modifiers = modifiers; + + switch (e->event_type) + { + case key_press_event: + e->event.key.modifiers = modifiers; + break; + case button_press_event: + case button_release_event: + e->event.button.modifiers = modifiers; + break; + case pointer_motion_event: + e->event.motion.modifiers = modifiers; + break; + case misc_user_event: + e->event.misc.modifiers = modifiers; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else if (EQ (keyword, Qx)) { - if (e->event_type != pointer_motion_event - && e->event_type != button_press_event - && e->event_type != button_release_event - && e->event_type != misc_user_event) + switch (e->event_type) { + case pointer_motion_event: + case button_press_event: + case button_release_event: + case misc_user_event: + /* Allow negative values, so we can specify toolbar + positions. */ + CHECK_INT (value); + coord_x = XINT (value); + break; + default: WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; } - /* Allow negative values, so we can specify toolbar - positions. */ - CHECK_INT (value); - coord_x = XINT (value); } else if (EQ (keyword, Qy)) { - if (e->event_type != pointer_motion_event - && e->event_type != button_press_event - && e->event_type != button_release_event - && e->event_type != misc_user_event) + switch (e->event_type) { + case pointer_motion_event: + case button_press_event: + case button_release_event: + case misc_user_event: + /* Allow negative values; see above. */ + CHECK_INT (value); + coord_y = XINT (value); + break; + default: WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; } - /* Allow negative values; see above. */ - CHECK_INT (value); - coord_y = XINT (value); } else if (EQ (keyword, Qtimestamp)) { @@ -604,15 +621,27 @@ } else if (EQ (keyword, Qfunction)) { - if (e->event_type != misc_user_event) - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - e->event.eval.function = value; + switch (e->event_type) + { + case misc_user_event: + e->event.eval.function = value; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else if (EQ (keyword, Qobject)) { - if (e->event_type != misc_user_event) - WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); - e->event.eval.object = value; + switch (e->event_type) + { + case misc_user_event: + e->event.eval.object = value; + break; + default: + WRONG_EVENT_TYPE_FOR_PROPERTY (type, keyword); + break; + } } else signal_simple_error_2 ("Invalid property", keyword, value); @@ -629,31 +658,28 @@ /* Fevent_properties, Fevent_x_pixel, etc. work with pixels relative to the frame, so we must adjust accordingly. */ - if (e->event_type == pointer_motion_event - || e->event_type == button_press_event - || e->event_type == button_release_event - || e->event_type == misc_user_event) + if (FRAMEP (EVENT_CHANNEL (e))) { - struct frame *f = XFRAME (EVENT_CHANNEL (e)); + coord_x += FRAME_REAL_LEFT_TOOLBAR_WIDTH (XFRAME (EVENT_CHANNEL (e))); + coord_y += FRAME_REAL_TOP_TOOLBAR_HEIGHT (XFRAME (EVENT_CHANNEL (e))); - coord_x += FRAME_REAL_LEFT_TOOLBAR_WIDTH (f); - coord_y += FRAME_REAL_TOP_TOOLBAR_HEIGHT (f); - - if (e->event_type == pointer_motion_event) + switch (e->event_type) { + case pointer_motion_event: e->event.motion.x = coord_x; e->event.motion.y = coord_y; - } - else if (e->event_type == button_press_event - || e->event_type == button_release_event) - { + break; + case button_press_event: + case button_release_event: e->event.button.x = coord_x; e->event.button.y = coord_y; - } - else if (e->event_type == misc_user_event) - { + break; + case misc_user_event: e->event.misc.x = coord_x; e->event.misc.y = coord_y; + break; + default: + abort(); } } @@ -661,20 +687,20 @@ switch (e->event_type) { case key_press_event: - if (UNBOUNDP (e->event.key.keysym) - || !(SYMBOLP (e->event.key.keysym) || CHARP (e->event.key.keysym))) - error ("Undefined key for keypress event"); + if (UNBOUNDP (e->event.key.keysym)) + error ("A key must be specified to make a keypress event"); break; case button_press_event: + if (!e->event.button.button) + error ("A button must be specified to make a button-press event"); + break; case button_release_event: if (!e->event.button.button) - error ("Undefined button for %s event", - e->event_type == button_press_event - ? "buton-press" : "button-release"); + error ("A button must be specified to make a button-release event"); break; case misc_user_event: if (NILP (e->event.misc.function)) - error ("Undefined function for misc-user event"); + error ("A function must be specified to make a misc-user event"); break; default: break; @@ -989,7 +1015,7 @@ } if (c >= 'A' && c <= 'Z') c -= 'A'-'a'; } -#if defined(HAVE_TTY) +#if defined(HAVE_TTY) else if (do_backspace_mapping && CHARP (con->tty_erase_char) && c == XCHAR (con->tty_erase_char)) k = QKbackspace; @@ -1253,8 +1279,8 @@ default: abort (); } -#define modprint1(x) { strcpy (buf, (x)); buf += sizeof (x)-1; } -#define modprint(x,y) { if (brief) modprint1 (y) else modprint1 (x) } +#define modprint1(x) do { strcpy (buf, (x)); buf += sizeof (x)-1; } while (0) +#define modprint(x,y) do { if (brief) modprint1 (y); else modprint1 (x); } while (0) if (mod & MOD_CONTROL) modprint ("control-", "C-"); if (mod & MOD_META) modprint ("meta-", "M-"); if (mod & MOD_SUPER) modprint ("super-", "S-"); @@ -2077,6 +2103,8 @@ switch (e->event_type) { + default: abort (); + case process_event: props = cons3 (Qprocess, e->event.process.process, props); break; @@ -2127,10 +2155,6 @@ case empty_event: RETURN_UNGCPRO (Qnil); break; - - default: - abort (); - break; /* not reached; warning suppression */ } props = cons3 (Qchannel, Fevent_channel (event), props); diff -r 76b7d63099ad -r 8626e4521993 src/events.h --- a/src/events.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/events.h Mon Aug 13 11:07:10 2007 +0200 @@ -115,7 +115,7 @@ have a separate input fd per device). create_stream_pair_cb These callbacks are called by process code to - delete_stream_pair_cb create and delete a pait of input and output lstreams + delete_stream_pair_cb create and delete a pair of input and output lstreams which are used for subprocess I/O. quitp_cb A handler function called from the `QUIT' macro which @@ -269,11 +269,11 @@ ------------------------ Since there are many possible processes/event loop combinations, the event code - is responsible for creating an appropriare lstream type. The process + is responsible for creating an appropriate lstream type. The process implementation does not care about that implementation. The Create stream pair function is passed two void* values, which identify - process-dependant 'handles'. The process implementation uses these handles + process-dependent 'handles'. The process implementation uses these handles to communicate with child processes. The function must be prepared to receive handle types of any process implementation. Since there only one process implementation exists in a particular XEmacs configuration, preprocessing @@ -293,20 +293,20 @@ corresponding lstream should not be created. The return value of the function is a unique stream identifier. It is used - by processes implementation, in its platform-independant part. There is + by processes implementation, in its platform-independent part. There is the get_process_from_usid function, which returns process object given its USID. The event stream is responsible for converting its internal handle type into USID. Example is the TTY event stream. When a file descriptor signals input, the event loop must determine process to which the input is destined. Thus, - the imlementation uses process input stream file descriptor as USID, by + the implementation uses process input stream file descriptor as USID, by simply casting the fd value to USID type. There are two special USID values. One, USID_ERROR, indicates that the stream pair cannot be created. The second, USID_DONTHASH, indicates that streams are created, but the event stream does not wish to be able to find the process - by its USID. Specifically, if an event stream implementation never calss + by its USID. Specifically, if an event stream implementation never calls get_process_from_usid, this value should always be returned, to prevent accumulating useless information on USID to process relationship. */ @@ -454,7 +454,7 @@ struct motion_data motion; struct process_data process; struct timeout_data timeout; - struct eval_data eval; /* misc_user_event no loger uses this */ + struct eval_data eval; /* misc_user_event no longer uses this */ struct misc_user_data misc; /* because it needs position information */ union magic_data magic; struct magic_eval_data magic_eval; @@ -519,16 +519,13 @@ /* Maybe this should be trickier */ #define KEYSYM(x) (intern (x)) -Lisp_Object allocate_command_builder (Lisp_Object console); - +/* from events.c */ void format_event_object (char *buf, struct Lisp_Event *e, int brief); void character_to_event (Emchar c, struct Lisp_Event *event, struct console *con, int use_console_meta_flag, int do_backspace_mapping); -void enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object); void zero_event (struct Lisp_Event *e); - void deallocate_event_chain (Lisp_Object event); Lisp_Object event_chain_tail (Lisp_Object event); void enqueue_event (Lisp_Object event, Lisp_Object *head, Lisp_Object *tail); @@ -542,17 +539,18 @@ Lisp_Object event); Lisp_Object event_chain_nth (Lisp_Object event_chain, int n); Lisp_Object copy_event_chain (Lisp_Object event_chain); - /* True if this is a non-internal event (keyboard press, menu, scrollbar, mouse button) */ int command_event_p (Lisp_Object event); - struct console *event_console_or_selected (Lisp_Object event); +/* from event-stream.c */ +Lisp_Object allocate_command_builder (Lisp_Object console); +void enqueue_magic_eval_event (void (*fun) (Lisp_Object), Lisp_Object object); void event_stream_next_event (struct Lisp_Event *event); void event_stream_handle_magic_event (struct Lisp_Event *event); -void event_stream_select_console (struct console *c); -void event_stream_unselect_console (struct console *c); +void event_stream_select_console (struct console *con); +void event_stream_unselect_console (struct console *con); void event_stream_select_process (struct Lisp_Process *proc); void event_stream_unselect_process (struct Lisp_Process *proc); USID event_stream_create_stream_pair (void* inhandle, void* outhandle, @@ -583,7 +581,6 @@ void event_stream_disable_wakeup (int id, int async_p); void event_stream_deal_with_async_timeout (int interval_id); -/* from signal.c */ int event_stream_add_async_timeout (EMACS_TIME thyme); void event_stream_remove_async_timeout (int id); @@ -601,7 +598,13 @@ void any_console_state (void); int in_single_console_state (void); +extern int emacs_is_blocking; + +extern volatile int sigint_happened; + #ifdef HAVE_UNIXOID_EVENT_LOOP +/* from event-unixoid.c */ + /* Ceci n'est pas un pipe. */ extern int signal_event_pipe[]; @@ -615,7 +618,7 @@ int event_stream_unixoid_select_process (struct Lisp_Process *proc); int event_stream_unixoid_unselect_process (struct Lisp_Process *proc); int read_event_from_tty_or_stream_desc (struct Lisp_Event *event, - struct console *c, int fd); + struct console *con, int fd); USID event_stream_unixoid_create_stream_pair (void* inhandle, void* outhandle, Lisp_Object* instream, Lisp_Object* outstream, @@ -628,10 +631,6 @@ #endif /* HAVE_UNIXOID_EVENT_LOOP */ -extern int emacs_is_blocking; - -extern volatile int sigint_happened; - /* Define this if you want the tty event stream to be used when the first console is tty, even if HAVE_X_WINDOWS is defined */ /* #define DEBUG_TTY_EVENT_STREAM */ diff -r 76b7d63099ad -r 8626e4521993 src/extents.c --- a/src/extents.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/extents.c Mon Aug 13 11:07:10 2007 +0200 @@ -222,7 +222,6 @@ #include "faces.h" #include "frame.h" #include "glyphs.h" -#include "hash.h" #include "insdel.h" #include "keymap.h" #include "opaque.h" @@ -536,7 +535,7 @@ int old_gap_size; /* If we have to get more space, get enough to last a while. We use - a geometric progession that saves on realloc space. */ + a geometric progression that saves on realloc space. */ increment += 100 + ga->numels / 8; ptr = (char *) xrealloc (ptr, @@ -914,15 +913,15 @@ mark_extent_auxiliary (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct extent_auxiliary *data = XEXTENT_AUXILIARY (obj); - ((markobj) (data->begin_glyph)); - ((markobj) (data->end_glyph)); - ((markobj) (data->invisible)); - ((markobj) (data->children)); - ((markobj) (data->read_only)); - ((markobj) (data->mouse_face)); - ((markobj) (data->initial_redisplay_function)); - ((markobj) (data->before_change_functions)); - ((markobj) (data->after_change_functions)); + markobj (data->begin_glyph); + markobj (data->end_glyph); + markobj (data->invisible); + markobj (data->children); + markobj (data->read_only); + markobj (data->mouse_face); + markobj (data->initial_redisplay_function); + markobj (data->before_change_functions); + markobj (data->after_change_functions); return data->parent; } @@ -976,10 +975,9 @@ static Lisp_Object mark_extent_info (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct extent_info *data = - (struct extent_info *) XEXTENT_INFO (obj); + struct extent_info *data = (struct extent_info *) XEXTENT_INFO (obj); int i; - Extent_List *list; + Extent_List *list = data->extents; /* Vbuffer_defaults and Vbuffer_local_symbols are buffer-like objects that are created specially and never have their extent @@ -990,7 +988,6 @@ (Also the list can be zero when we're dealing with a destroyed buffer.) */ - list = data->extents; if (list) { for (i = 0; i < extent_list_num_els (list); i++) @@ -999,7 +996,7 @@ Lisp_Object exobj; XSETEXTENT (exobj, extent); - ((markobj) (exobj)); + markobj (exobj); } } @@ -1608,7 +1605,7 @@ force the modeline to be updated. But how to determine whether a string is a `generated-modeline-string'? Looping through all buffers is not very efficient. Should we add all - `generated-modeline-string' strings to a hashtable? + `generated-modeline-string' strings to a hash table? Maybe efficiency is not the greatest concern here and there's no big loss in looping over the buffers. */ return; @@ -1824,7 +1821,7 @@ Endpoint_Index start, end, exs, exe; int start_open, end_open; unsigned int all_extents_flags = flags & ME_ALL_EXTENTS_MASK; - unsigned int in_region_flags = flags & ME_IN_REGION_MASK; + unsigned int in_region_flags = flags & ME_IN_REGION_MASK; int retval; /* A zero-length region is treated as closed-closed. */ @@ -1834,31 +1831,30 @@ flags &= ~ME_START_OPEN; } - switch (all_extents_flags) - { - 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; - } - /* So is a zero-length extent. */ if (extent_start (extent) == extent_end (extent)) - start_open = end_open = 0; + start_open = 0, end_open = 0; + /* `all_extents_flags' will almost always be zero. */ + else if (all_extents_flags == 0) + { + start_open = extent_start_open_p (extent); + end_open = extent_end_open_p (extent); + } + else + switch (all_extents_flags) + { + case ME_ALL_EXTENTS_CLOSED: start_open = 0, end_open = 0; break; + case ME_ALL_EXTENTS_OPEN: start_open = 1, end_open = 1; break; + case ME_ALL_EXTENTS_CLOSED_OPEN: start_open = 0, end_open = 1; break; + case ME_ALL_EXTENTS_OPEN_CLOSED: start_open = 1, end_open = 0; break; + default: abort(); break; + } start = buffer_or_string_bytind_to_startind (obj, from, flags & ME_START_OPEN); end = buffer_or_string_bytind_to_endind (obj, to, ! (flags & ME_END_CLOSED)); exs = memind_to_startind (extent_start (extent), start_open); - exe = memind_to_endind (extent_end (extent), end_open); + exe = memind_to_endind (extent_end (extent), end_open); /* It's easy to determine whether an extent lies *outside* the region -- just determine whether it's completely before @@ -1870,20 +1866,24 @@ return 0; /* See if any further restrictions are called for. */ - switch (in_region_flags) - { - case ME_START_IN_REGION: - retval = start <= exs && exs <= end; break; - case ME_END_IN_REGION: - retval = start <= exe && exe <= end; break; - case ME_START_AND_END_IN_REGION: - retval = start <= exs && exe <= end; break; - case ME_START_OR_END_IN_REGION: - retval = (start <= exs && exs <= end) || (start <= exe && exe <= end); - break; - default: - retval = 1; break; - } + /* in_region_flags will almost always be zero. */ + if (in_region_flags == 0) + retval = 1; + else + switch (in_region_flags) + { + case ME_START_IN_REGION: + retval = start <= exs && exs <= end; break; + case ME_END_IN_REGION: + retval = start <= exe && exe <= end; break; + case ME_START_AND_END_IN_REGION: + retval = start <= exs && exe <= end; break; + case ME_START_OR_END_IN_REGION: + retval = (start <= exs && exs <= end) || (start <= exe && exe <= end); + break; + default: + abort(); break; + } return flags & ME_NEGATE_IN_REGION ? !retval : retval; } @@ -2866,7 +2866,7 @@ xzero (dummy_lhe_extent); set_extent_priority (&dummy_lhe_extent, mouse_highlight_priority); - /* Need to break up thefollowing expression, due to an */ + /* Need to break up the following expression, due to an */ /* error in the Digital UNIX 3.2g C compiler (Digital */ /* UNIX Compiler Driver 3.11). */ f = extent_mouse_face (lhe); @@ -2942,8 +2942,8 @@ { struct extent *extent = XEXTENT (obj); - ((markobj) (extent_object (extent))); - ((markobj) (extent_no_chase_normal_field (extent, face))); + markobj (extent_object (extent)); + markobj (extent_no_chase_normal_field (extent, face)); return extent->plist; } @@ -2995,7 +2995,7 @@ write_c_string (" ", printcharfun); } - sprintf (buf, "0x%lx", (unsigned long int) ext); + sprintf (buf, "0x%lx", (long) ext); write_c_string (buf, printcharfun); } @@ -3042,8 +3042,8 @@ if (!EXTENT_LIVE_P (XEXTENT (obj))) error ("printing unreadable object #"); else - error ("printing unreadable object #", - XEXTENT (obj)); + error ("printing unreadable object #", + (long) XEXTENT (obj)); } if (!EXTENT_LIVE_P (XEXTENT (obj))) @@ -3106,13 +3106,13 @@ } static int -extent_equal (Lisp_Object o1, Lisp_Object o2, int depth) -{ - struct extent *e1 = XEXTENT (o1); - struct extent *e2 = XEXTENT (o2); +extent_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) +{ + struct extent *e1 = XEXTENT (obj1); + struct extent *e2 = XEXTENT (obj2); return (extent_start (e1) == extent_start (e2) && - extent_end (e1) == extent_end (e2) && + extent_end (e1) == extent_end (e2) && internal_equal (extent_object (e1), extent_object (e2), depth + 1) && properties_equal (extent_ancestor (e1), extent_ancestor (e2), depth)); @@ -4748,7 +4748,7 @@ on the keys so the memoization works correctly. Note that we canonicalize things so that the keys in the - hashtable (the external lists) always contain symbols and + hash table (the external lists) always contain symbols and the values (the internal lists) always contain face objects. We also maintain a "reverse" table that maps from the internal @@ -4998,7 +4998,7 @@ if (EQ (layout_obj, Qwhitespace)) return GL_WHITESPACE; if (EQ (layout_obj, Qtext)) return GL_TEXT; - signal_simple_error ("unknown glyph layout type", layout_obj); + signal_simple_error ("Unknown glyph layout type", layout_obj); return GL_TEXT; /* unreached */ } @@ -5325,23 +5325,15 @@ Fset_extent_begin_glyph (extent, value, Qnil); else if (EQ (property, Qend_glyph)) Fset_extent_end_glyph (extent, value, Qnil); - else if (EQ (property, Qstart_open) || - EQ (property, Qend_open) || - EQ (property, Qstart_closed) || - EQ (property, Qend_closed)) - { - int start_open = -1, end_open = -1; - if (EQ (property, Qstart_open)) - start_open = !NILP (value); - else if (EQ (property, Qend_open)) - end_open = !NILP (value); - /* Support (but don't document...) the obvious antonyms. */ - else if (EQ (property, Qstart_closed)) - start_open = NILP (value); - else - end_open = NILP (value); - set_extent_openness (e, start_open, end_open); - } + else if (EQ (property, Qstart_open)) + set_extent_openness (e, !NILP (value), -1); + else if (EQ (property, Qend_open)) + set_extent_openness (e, -1, !NILP (value)); + /* Support (but don't document...) the obvious *_closed antonyms. */ + else if (EQ (property, Qstart_closed)) + set_extent_openness (e, NILP (value), -1); + else if (EQ (property, Qend_closed)) + set_extent_openness (e, -1, NILP (value)); else { if (EQ (property, Qkeymap)) @@ -5387,18 +5379,21 @@ { EXTENT e = decode_extent (extent, 0); - if (EQ (property, Qdetached)) + if (EQ (property, Qdetached)) return extent_detached_p (e) ? Qt : Qnil; else if (EQ (property, Qdestroyed)) return !EXTENT_LIVE_P (e) ? Qt : Qnil; -#define RETURN_FLAG(flag) return extent_normal_field (e, flag) ? Qt : Qnil - else if (EQ (property, Qstart_open)) RETURN_FLAG (start_open); - else if (EQ (property, Qend_open)) RETURN_FLAG (end_open); - else if (EQ (property, Qunique)) RETURN_FLAG (unique); - else if (EQ (property, Qduplicable)) RETURN_FLAG (duplicable); - else if (EQ (property, Qdetachable)) RETURN_FLAG (detachable); -#undef RETURN_FLAG - /* Support (but don't document...) the obvious antonyms. */ + else if (EQ (property, Qstart_open)) + return extent_normal_field (e, start_open) ? Qt : Qnil; + else if (EQ (property, Qend_open)) + return extent_normal_field (e, end_open) ? Qt : Qnil; + else if (EQ (property, Qunique)) + return extent_normal_field (e, unique) ? Qt : Qnil; + else if (EQ (property, Qduplicable)) + return extent_normal_field (e, duplicable) ? Qt : Qnil; + else if (EQ (property, Qdetachable)) + return extent_normal_field (e, detachable) ? Qt : Qnil; + /* Support (but don't document...) the obvious *_closed antonyms. */ else if (EQ (property, Qstart_closed)) return extent_start_open_p (e) ? Qnil : Qt; else if (EQ (property, Qend_closed)) @@ -5755,12 +5750,10 @@ struct add_string_extents_arg *closure = (struct add_string_extents_arg *) arg; Bytecount start = extent_endpoint_bytind (extent, 0) - closure->from; - Bytecount end = extent_endpoint_bytind (extent, 1) - closure->from; + Bytecount end = extent_endpoint_bytind (extent, 1) - closure->from; if (extent_duplicable_p (extent)) { - EXTENT e; - start = max (start, 0); end = min (end, closure->length); @@ -5771,7 +5764,7 @@ !run_extent_copy_function (extent, start + closure->from, end + closure->from)) return 0; - e = copy_extent (extent, start, end, closure->string); + copy_extent (extent, start, end, closure->string); } return 0; @@ -5896,25 +5889,21 @@ { 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; - - copy_extent (extent, - old_start + closure->new_pos - closure->old_pos, - old_end + closure->new_pos - closure->old_pos, - closure->new_string); + new_end = old_end + closure->new_pos - closure->old_pos; + + copy_extent (extent, new_start, new_end, closure->new_string); return 0; } @@ -6514,7 +6503,7 @@ prop = Fextent_property (extent, Qtext_prop, Qnil); if (NILP (prop)) - signal_simple_error ("internal error: no text-prop", extent); + signal_simple_error ("Internal error: no text-prop", extent); val = Fextent_property (extent, prop, Qnil); #if 0 /* removed by bill perry, 2/9/97 @@ -6522,7 +6511,7 @@ ** with a value of Qnil. This is bad bad bad. */ if (NILP (val)) - signal_simple_error_2 ("internal error: no text-prop", + signal_simple_error_2 ("Internal error: no text-prop", extent, prop); #endif Fput_text_property (from, to, prop, val, Qnil); @@ -6814,7 +6803,7 @@ /* Set mouse-highlight-priority (which ends up being used both for the mouse-highlighting pseudo-extent and the primary selection extent) to a very high value because very few extents should override it. - 1000 gives lots of room below it for different-prioritied extents. + 1000 gives lots of room below it for different-prioritized extents. 10 doesn't. ediff, for example, likes to use priorities around 100. --ben */ mouse_highlight_priority = /* 10 */ 1000; @@ -6850,14 +6839,14 @@ complex_vars_of_extents (void) { staticpro (&Vextent_face_memoize_hash_table); - /* The memoize hash-table maps from lists of symbols to lists of + /* The memoize hash table maps from lists of symbols to lists of faces. It needs to be `equal' to implement the memoization. The reverse table maps in the other direction and just needs to do `eq' comparison because the lists of faces are already memoized. */ Vextent_face_memoize_hash_table = - make_lisp_hashtable (100, HASHTABLE_VALUE_WEAK, HASHTABLE_EQUAL); + make_lisp_hash_table (100, HASH_TABLE_VALUE_WEAK, HASH_TABLE_EQUAL); staticpro (&Vextent_face_reverse_memoize_hash_table); Vextent_face_reverse_memoize_hash_table = - make_lisp_hashtable (100, HASHTABLE_KEY_WEAK, HASHTABLE_EQ); -} + make_lisp_hash_table (100, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); +} diff -r 76b7d63099ad -r 8626e4521993 src/extents.h --- a/src/extents.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/extents.h Mon Aug 13 11:07:10 2007 +0200 @@ -103,8 +103,8 @@ #define extent_object(e) ((e)->object) #define extent_start(e) ((e)->start + 0) #define extent_end(e) ((e)->end + 0) -#define set_extent_start(e, val) ((e)->start = (val)) -#define set_extent_end(e, val) ((e)->end = (val)) +#define set_extent_start(e, val) ((void) ((e)->start = (val))) +#define set_extent_end(e, val) ((void) ((e)->end = (val))) #define extent_endpoint(e, endp) ((endp) ? extent_end (e) : extent_start (e)) #define set_extent_endpoint(e, val, endp) \ ((endp) ? set_extent_end (e, val) : set_extent_start (e, val)) diff -r 76b7d63099ad -r 8626e4521993 src/faces.c --- a/src/faces.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/faces.c Mon Aug 13 11:07:10 2007 +0200 @@ -36,7 +36,6 @@ #include "faces.h" #include "frame.h" #include "glyphs.h" -#include "hash.h" #include "objects.h" #include "specifier.h" #include "window.h" @@ -78,22 +77,22 @@ { struct Lisp_Face *face = XFACE (obj); - ((markobj) (face->name)); - ((markobj) (face->doc_string)); + markobj (face->name); + markobj (face->doc_string); - ((markobj) (face->foreground)); - ((markobj) (face->background)); - ((markobj) (face->font)); - ((markobj) (face->display_table)); - ((markobj) (face->background_pixmap)); - ((markobj) (face->underline)); - ((markobj) (face->strikethru)); - ((markobj) (face->highlight)); - ((markobj) (face->dim)); - ((markobj) (face->blinking)); - ((markobj) (face->reverse)); + markobj (face->foreground); + markobj (face->background); + markobj (face->font); + markobj (face->display_table); + markobj (face->background_pixmap); + markobj (face->underline); + markobj (face->strikethru); + markobj (face->highlight); + markobj (face->dim); + markobj (face->blinking); + markobj (face->reverse); - ((markobj) (face->charsets_warned_about)); + markobj (face->charsets_warned_about); return face->plist; } @@ -129,10 +128,10 @@ This isn't concerned with "unspecified" attributes, that's what #'face-differs-from-default-p is for. */ static int -face_equal (Lisp_Object o1, Lisp_Object o2, int depth) +face_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Face *f1 = XFACE (o1); - struct Lisp_Face *f2 = XFACE (o2); + struct Lisp_Face *f1 = XFACE (obj1); + struct Lisp_Face *f2 = XFACE (obj2); depth++; @@ -375,19 +374,14 @@ }; static int -add_face_to_list_mapper (CONST void *hash_key, void *hash_contents, +add_face_to_list_mapper (Lisp_Object key, Lisp_Object value, void *face_list_closure) { /* This function can GC */ - Lisp_Object key, contents; - Lisp_Object *face_list; struct face_list_closure *fcl = (struct face_list_closure *) face_list_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - face_list = fcl->face_list; - *face_list = Fcons (XFACE (contents)->name, *face_list); + *(fcl->face_list) = Fcons (XFACE (value)->name, (*fcl->face_list)); return 0; } @@ -420,15 +414,12 @@ static int -mark_face_as_clean_mapper (CONST void *hash_key, void *hash_contents, +mark_face_as_clean_mapper (Lisp_Object key, Lisp_Object value, void *flag_closure) { /* This function can GC */ - Lisp_Object key, contents; int *flag = (int *) flag_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - XFACE (contents)->dirty = *flag; + XFACE (value)->dirty = *flag; return 0; } @@ -1007,13 +998,13 @@ for (i = 0; i < NUM_LEADING_BYTES; i++) if (!NILP (cachel->font[i]) && !UNBOUNDP (cachel->font[i])) - ((markobj) (cachel->font[i])); + markobj (cachel->font[i]); } - ((markobj) (cachel->face)); - ((markobj) (cachel->foreground)); - ((markobj) (cachel->background)); - ((markobj) (cachel->display_table)); - ((markobj) (cachel->background_pixmap)); + markobj (cachel->face); + markobj (cachel->foreground); + markobj (cachel->background); + markobj (cachel->display_table); + markobj (cachel->background_pixmap); } } @@ -1638,23 +1629,19 @@ if (WINDOWP (locale)) { - struct frame *f = XFRAME (XWINDOW (locale)->frame); - MARK_FRAME_FACES_CHANGED (f); + MARK_FRAME_FACES_CHANGED (XFRAME (XWINDOW (locale)->frame)); } else if (FRAMEP (locale)) { - struct frame *f = XFRAME (locale); - MARK_FRAME_FACES_CHANGED (f); + MARK_FRAME_FACES_CHANGED (XFRAME (locale)); } else if (DEVICEP (locale)) { - struct device *d = XDEVICE (locale); - MARK_DEVICE_FRAMES_FACES_CHANGED (d); + MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (locale)); } else { Lisp_Object devcons, concons; - DEVICE_LOOP_NO_BREAK (devcons, concons) MARK_DEVICE_FRAMES_FACES_CHANGED (XDEVICE (XCAR (devcons))); } @@ -1846,10 +1833,10 @@ void complex_vars_of_faces (void) { - Vpermanent_faces_cache = make_lisp_hashtable (10, HASHTABLE_NONWEAK, - HASHTABLE_EQ); - Vtemporary_faces_cache = make_lisp_hashtable (0, HASHTABLE_WEAK, - HASHTABLE_EQ); + Vpermanent_faces_cache = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + Vtemporary_faces_cache = + make_lisp_hash_table (0, HASH_TABLE_WEAK, HASH_TABLE_EQ); /* Create the default face now so we know what it is immediately. */ @@ -1941,7 +1928,7 @@ list1 (Fcons (Qnil, Qnil))); set_specifier_fallback (Fget (Vdefault_face, Qreverse, Qnil), list1 (Fcons (Qnil, Qnil))); - + /* gui-element is the parent face of all gui elements such as modeline, vertical divider and toolbar. */ Vgui_element_face = Fmake_face (Qgui_element, @@ -1984,7 +1971,7 @@ set_specifier_fallback (Fget (Vmodeline_face, Qbackground_pixmap, Qnil), Fget (Vgui_element_face, Qbackground_pixmap, Qunbound)); - + /* toolbar is another gui element */ Vtoolbar_face = Fmake_face (Qtoolbar, build_string ("toolbar face"), diff -r 76b7d63099ad -r 8626e4521993 src/faces.h --- a/src/faces.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/faces.h Mon Aug 13 11:07:10 2007 +0200 @@ -215,7 +215,7 @@ right sort are available on the system. In this case, the whole program will just crash. For the moment, this is OK (for debugging purposes) but we should fix this by - storing a "blank font" if the instantation fails. */ + storing a "blank font" if the instantiation fails. */ unsigned int dirty :1; unsigned int updated :1; /* #### Of course we should use a bit array or something. */ @@ -260,7 +260,7 @@ extern Lisp_Object Qstrikethru, Vbuilt_in_face_specifiers, Vdefault_face; extern Lisp_Object Vleft_margin_face, Vpointer_face, Vright_margin_face; -extern Lisp_Object Vtext_cursor_face, Vvertical_divider_face; +extern Lisp_Object Vtext_cursor_face, Vvertical_divider_face; extern Lisp_Object Vtoolbar_face, Vgui_element_face; void mark_all_faces_as_clean (void); diff -r 76b7d63099ad -r 8626e4521993 src/file-coding.c --- a/src/file-coding.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/file-coding.c Mon Aug 13 11:07:10 2007 +0200 @@ -75,7 +75,7 @@ #endif Lisp_Object Qencode, Qdecode; -Lisp_Object Vcoding_system_hashtable; +Lisp_Object Vcoding_system_hash_table; int enable_multibyte_characters; @@ -232,12 +232,12 @@ { struct Lisp_Coding_System *codesys = XCODING_SYSTEM (obj); - (markobj) (CODING_SYSTEM_NAME (codesys)); - (markobj) (CODING_SYSTEM_DOC_STRING (codesys)); - (markobj) (CODING_SYSTEM_MNEMONIC (codesys)); - (markobj) (CODING_SYSTEM_EOL_LF (codesys)); - (markobj) (CODING_SYSTEM_EOL_CRLF (codesys)); - (markobj) (CODING_SYSTEM_EOL_CR (codesys)); + markobj (CODING_SYSTEM_NAME (codesys)); + markobj (CODING_SYSTEM_DOC_STRING (codesys)); + markobj (CODING_SYSTEM_MNEMONIC (codesys)); + markobj (CODING_SYSTEM_EOL_LF (codesys)); + markobj (CODING_SYSTEM_EOL_CRLF (codesys)); + markobj (CODING_SYSTEM_EOL_CR (codesys)); switch (CODING_SYSTEM_TYPE (codesys)) { @@ -245,15 +245,15 @@ int i; case CODESYS_ISO2022: for (i = 0; i < 4; i++) - (markobj) (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i)); + markobj (CODING_SYSTEM_ISO2022_INITIAL_CHARSET (codesys, i)); if (codesys->iso2022.input_conv) { for (i = 0; i < Dynarr_length (codesys->iso2022.input_conv); i++) { struct charset_conversion_spec *ccs = Dynarr_atp (codesys->iso2022.input_conv, i); - (markobj) (ccs->from_charset); - (markobj) (ccs->to_charset); + markobj (ccs->from_charset); + markobj (ccs->to_charset); } } if (codesys->iso2022.output_conv) @@ -262,22 +262,22 @@ { struct charset_conversion_spec *ccs = Dynarr_atp (codesys->iso2022.output_conv, i); - (markobj) (ccs->from_charset); - (markobj) (ccs->to_charset); + markobj (ccs->from_charset); + markobj (ccs->to_charset); } } break; case CODESYS_CCL: - (markobj) (CODING_SYSTEM_CCL_DECODE (codesys)); - (markobj) (CODING_SYSTEM_CCL_ENCODE (codesys)); + markobj (CODING_SYSTEM_CCL_DECODE (codesys)); + markobj (CODING_SYSTEM_CCL_ENCODE (codesys)); break; #endif /* MULE */ default: break; } - (markobj) (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys)); + markobj (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys)); return CODING_SYSTEM_POST_READ_CONVERSION (codesys); } @@ -344,11 +344,11 @@ { switch (type) { + default: abort (); case EOL_LF: return Qlf; case EOL_CRLF: return Qcrlf; case EOL_CR: return Qcr; case EOL_AUTODETECT: return Qnil; - default: abort (); return Qnil; /* not reached */ } } @@ -439,7 +439,7 @@ else CHECK_SYMBOL (coding_system_or_name); - return Fgethash (coding_system_or_name, Vcoding_system_hashtable, Qnil); + return Fgethash (coding_system_or_name, Vcoding_system_hash_table, Qnil); } DEFUN ("get-coding-system", Fget_coding_system, 1, 1, 0, /* @@ -465,19 +465,15 @@ }; 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; - - *coding_system_list = Fcons (XCODING_SYSTEM (contents)->name, + Lisp_Object *coding_system_list = cscl->coding_system_list; + + *coding_system_list = Fcons (XCODING_SYSTEM (value)->name, *coding_system_list); return 0; } @@ -493,7 +489,7 @@ GCPRO1 (coding_system_list); coding_system_list_closure.coding_system_list = &coding_system_list; - elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hashtable, + elisp_maphash (add_coding_system_to_list_mapper, Vcoding_system_hash_table, &coding_system_list_closure); UNGCPRO; @@ -890,7 +886,7 @@ { Lisp_Object codesys_obj; XSETCODING_SYSTEM (codesys_obj, codesys); - Fputhash (name, codesys_obj, Vcoding_system_hashtable); + Fputhash (name, codesys_obj, Vcoding_system_hash_table); return codesys_obj; } } @@ -911,7 +907,7 @@ allocate_coding_system (XCODING_SYSTEM_TYPE (old_coding_system), new_name)); - Fputhash (new_name, new_coding_system, Vcoding_system_hashtable); + Fputhash (new_name, new_coding_system, Vcoding_system_hash_table); } { @@ -978,6 +974,7 @@ { switch (XCODING_SYSTEM_TYPE (Fget_coding_system (coding_system))) { + default: abort (); case CODESYS_AUTODETECT: return Qundecided; #ifdef MULE case CODESYS_SHIFT_JIS: return Qshift_jis; @@ -989,11 +986,7 @@ #ifdef DEBUG_XEMACS case CODESYS_INTERNAL: return Qinternal; #endif - default: - abort (); } - - return Qnil; /* not reached */ } #ifdef MULE @@ -1746,7 +1739,7 @@ and automatically marked. */ XSETLSTREAM (str_obj, str); - (markobj) (str_obj); + markobj (str_obj); if (str->imp->marker) return (str->imp->marker) (str_obj, markobj); else @@ -2192,7 +2185,7 @@ and automatically marked. */ XSETLSTREAM (str_obj, str); - (markobj) (str_obj); + markobj (str_obj); if (str->imp->marker) return (str->imp->marker) (str_obj, markobj); else @@ -2748,7 +2741,7 @@ Since the number of characters in Big5 is larger than maximum characters in Emacs' charset (96x96), it can't be handled as one - charset. So, in Emacs, Big5 is devided into two: `charset-big5-1' + charset. So, in Emacs, Big5 is divided into two: `charset-big5-1' and `charset-big5-2'. Both s are TYPE94x94. The former contains frequently used characters and the latter contains less frequently used characters. */ @@ -4484,24 +4477,27 @@ /* Determine coding system from coding format */ -#define FILE_NAME_CODING_SYSTEM \ - ((NILP (Vfile_name_coding_system) || \ - (EQ ((Vfile_name_coding_system), Qbinary))) ? \ - Qnil : Fget_coding_system (Vfile_name_coding_system)) - /* #### not correct for all values of `fmt'! */ +static Lisp_Object +external_data_format_to_coding_system (enum external_data_format fmt) +{ + switch (fmt) + { + case FORMAT_FILENAME: + case FORMAT_TERMINAL: + if (EQ (Vfile_name_coding_system, Qnil) || + EQ (Vfile_name_coding_system, Qbinary)) + return Qnil; + else + return Fget_coding_system (Vfile_name_coding_system); #ifdef MULE -#define FMT_CODING_SYSTEM(fmt) \ - (((fmt) == FORMAT_FILENAME) ? FILE_NAME_CODING_SYSTEM : \ - ((fmt) == FORMAT_CTEXT ) ? Fget_coding_system (Qctext) : \ - ((fmt) == FORMAT_TERMINAL) ? FILE_NAME_CODING_SYSTEM : \ - Qnil) -#else -#define FMT_CODING_SYSTEM(fmt) \ - (((fmt) == FORMAT_FILENAME) ? FILE_NAME_CODING_SYSTEM : \ - ((fmt) == FORMAT_TERMINAL) ? FILE_NAME_CODING_SYSTEM : \ - Qnil) + case FORMAT_CTEXT: + return Fget_coding_system (Qctext); #endif + default: + return Qnil; + } +} Extbyte * convert_to_external_format (CONST Bufbyte *ptr, @@ -4509,7 +4505,7 @@ Extcount *len_out, enum external_data_format fmt) { - Lisp_Object coding_system = FMT_CODING_SYSTEM (fmt); + Lisp_Object coding_system = external_data_format_to_coding_system (fmt); if (!conversion_out_dynarr) conversion_out_dynarr = Dynarr_new (Extbyte); @@ -4577,7 +4573,7 @@ Bytecount *len_out, enum external_data_format fmt) { - Lisp_Object coding_system = FMT_CODING_SYSTEM (fmt); + Lisp_Object coding_system = external_data_format_to_coding_system (fmt); if (!conversion_in_dynarr) conversion_in_dynarr = Dynarr_new (Bufbyte); @@ -4819,9 +4815,9 @@ void complex_vars_of_mule_coding (void) { - staticpro (&Vcoding_system_hashtable); - Vcoding_system_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + staticpro (&Vcoding_system_hash_table); + Vcoding_system_hash_table = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); the_codesys_prop_dynarr = Dynarr_new (codesys_prop); diff -r 76b7d63099ad -r 8626e4521993 src/file-coding.h --- a/src/file-coding.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/file-coding.h Mon Aug 13 11:07:10 2007 +0200 @@ -256,7 +256,7 @@ extern Lisp_Object Qno_iso6429, Qoutput_charset_conversion; extern Lisp_Object Qpost_read_conversion, Qpre_write_conversion, Qseven; extern Lisp_Object Qshift_jis, Qshort, Vcoding_system_for_read; -extern Lisp_Object Vcoding_system_for_write, Vcoding_system_hashtable; +extern Lisp_Object Vcoding_system_for_write, Vcoding_system_hash_table; extern Lisp_Object Vfile_name_coding_system, Vkeyboard_coding_system; extern Lisp_Object Vterminal_coding_system; diff -r 76b7d63099ad -r 8626e4521993 src/fileio.c --- a/src/fileio.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/fileio.c Mon Aug 13 11:07:10 2007 +0200 @@ -438,7 +438,7 @@ while (p != beg && !IS_ANY_SEP (p[-1]) #ifdef WINDOWSNT - /* only recognise drive specifier at beginning */ + /* only recognize drive specifier at beginning */ && !(p[-1] == ':' && p == beg + 2) #endif ) p--; @@ -493,7 +493,7 @@ while (p != beg && !IS_ANY_SEP (p[-1]) #ifdef WINDOWSNT - /* only recognise drive specifier at beginning */ + /* only recognize drive specifier at beginning */ && !(p[-1] == ':' && p == beg + 2) #endif ) p--; @@ -742,18 +742,17 @@ /* We want to return only if errno is ENOENT. */ if (errno == ENOENT) return val; - else - /* The error here is dubious, but there is little else we - can do. The alternatives are to return nil, which is - as bad as (and in many cases worse than) throwing the - error, or to ignore the error, which will likely result - in inflooping. */ - report_file_error ("Cannot create temporary name for prefix", - list1 (prefix)); - /* not reached */ + + /* The error here is dubious, but there is little else we + can do. The alternatives are to return nil, which is + as bad as (and in many cases worse than) throwing the + error, or to ignore the error, which will likely result + in inflooping. */ + report_file_error ("Cannot create temporary name for prefix", + list1 (prefix)); + return Qnil; /* not reached */ } } - RETURN_NOT_REACHED (Qnil); } @@ -869,7 +868,7 @@ if (colon) /* Only recognize colon as part of drive specifier if there is a - single alphabetic character preceeding the colon (and if the + single alphabetic character preceding the colon (and if the character before the drive letter, if present, is a directory separator); this is to support the remote system syntax used by ange-ftp, and the "po:username" syntax for POP mailboxes. */ @@ -991,7 +990,8 @@ } else /* ~user/filename */ { - for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++); + for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++) + DO_NOTHING; o = (Bufbyte *) alloca (p - nm + 1); memcpy (o, (char *) nm, p - nm); o [p - nm] = 0; @@ -1018,13 +1018,13 @@ { /* Does the user login name match the ~name? */ if (strcmp(user,((char *) o + 1)) == 0) - { + { newdir = (Bufbyte *) get_home_directory(); nm = p; } } if (! newdir) - { + { #endif /* __CYGWIN32__ */ /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM occurring in it. (It can call select()). */ @@ -1770,7 +1770,7 @@ } #endif /* S_ISREG && S_ISLNK */ - ofd = open( (char *) XSTRING_DATA (newname), + ofd = open( (char *) XSTRING_DATA (newname), O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE); if (ofd < 0) report_file_error ("Opening output file", list1 (newname)); @@ -2049,7 +2049,7 @@ on NT here. --marcpa */ /* But FSF #defines link as sys_link which is supplied in nt.c. We can't do that because sysfile.h defines sys_link depending on ENCAPSULATE_LINK. - Reverted to previous behaviour pending a working fix. (jhar) */ + Reverted to previous behavior pending a working fix. (jhar) */ #if defined(WINDOWSNT) /* Windows does not support this operation. */ report_file_error ("Adding new name", Flist (2, &filename)); @@ -2525,7 +2525,7 @@ /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */ #if 0 #ifdef DOS_NT - if (check_executable (XSTRING (abspath)->_data)) + if (check_executable (XSTRING_DATA (abspath))) st.st_mode |= S_IEXEC; #endif /* DOS_NT */ #endif /* 0 */ @@ -3346,10 +3346,10 @@ /* On VMS and APOLLO, must do the stat after the close since closing changes the modtime. */ /* As it does on Windows too - kkm */ - /* The spurious warnings appear on Linux too. Rather than handling + /* The spurious warnings appear on Linux too. Rather than handling this on a per-system basis, unconditionally do the stat after the close - cgw */ - -#if 0 /* !defined (WINDOWSNT) /* !defined (VMS) && !defined (APOLLO) */ + +#if 0 /* !defined (WINDOWSNT) */ /* !defined (VMS) && !defined (APOLLO) */ fstat (desc, &st); #endif @@ -3367,7 +3367,7 @@ unbind_to (speccount, Qnil); } - /* # if defined (WINDOWSNT) /* defined (VMS) || defined (APOLLO) */ + /* # if defined (WINDOWSNT) */ /* defined (VMS) || defined (APOLLO) */ stat ((char *) XSTRING_DATA (fn), &st); /* #endif */ @@ -3429,7 +3429,10 @@ */ (a, b)) { - return arithcompare (Fcar (a), Fcar (b), arith_less); + Lisp_Object objs[2]; + objs[0] = Fcar (a); + objs[1] = Fcar (b); + return Flss (2, objs); } /* Heh heh heh, let's define this too, just to aggravate the person who @@ -3439,7 +3442,10 @@ */ (a, b)) { - return arithcompare (Fcdr (a), Fcdr (b), arith_less); + Lisp_Object objs[2]; + objs[0] = Fcdr (a); + objs[1] = Fcdr (b); + return Flss (2, objs); } /* Build the complete list of annotations appropriate for writing out @@ -3828,7 +3834,7 @@ struct gcpro gcpro1; /* note that caller did NOT gc protect name, so we do it. */ - /* #### dmoore - this might not be neccessary, if condition_case_1 + /* #### dmoore - this might not be necessary, if condition_case_1 protects it. but I don't think it does. */ GCPRO1 (name); RETURN_UNGCPRO (Fexpand_file_name (name, Qnil)); diff -r 76b7d63099ad -r 8626e4521993 src/floatfns.c --- a/src/floatfns.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/floatfns.c Mon Aug 13 11:07:10 2007 +0200 @@ -162,13 +162,13 @@ static Lisp_Object mark_float (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - return (Qnil); + return Qnil; } static int -float_equal (Lisp_Object o1, Lisp_Object o2, int depth) +float_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - return (extract_float (o1) == extract_float (o2)); + return (extract_float (obj1) == extract_float (obj2)); } static unsigned long @@ -188,11 +188,13 @@ double extract_float (Lisp_Object num) { - CHECK_INT_OR_FLOAT (num); + if (FLOATP (num)) + return XFLOAT_DATA (num); - if (FLOATP (num)) - return (float_data (XFLOAT (num))); - return (double) XINT (num); + if (INTP (num)) + return (double) XINT (num); + + return extract_float (wrong_type_argument (num, Qnumberp)); } #endif /* LISP_FLOAT_TYPE */ @@ -422,53 +424,54 @@ */ (arg1, arg2)) { - double f1, f2; - - CHECK_INT_OR_FLOAT (arg1); - CHECK_INT_OR_FLOAT (arg2); - if ((INTP (arg1)) && /* common lisp spec */ - (INTP (arg2))) /* don't promote, if both are ints */ + if (INTP (arg1) && /* common lisp spec */ + INTP (arg2)) /* don't promote, if both are ints */ { - EMACS_INT acc, x, y; - x = XINT (arg1); - y = XINT (arg2); + EMACS_INT retval; + EMACS_INT x = XINT (arg1); + EMACS_INT y = XINT (arg2); if (y < 0) { if (x == 1) - acc = 1; + retval = 1; else if (x == -1) - acc = (y & 1) ? -1 : 1; + retval = (y & 1) ? -1 : 1; else - acc = 0; + retval = 0; } else { - acc = 1; + retval = 1; while (y > 0) { if (y & 1) - acc *= x; + retval *= x; x *= x; y = (EMACS_UINT) y >> 1; } } - return (make_int (acc)); + return make_int (retval); } + #ifdef LISP_FLOAT_TYPE - f1 = (FLOATP (arg1)) ? float_data (XFLOAT (arg1)) : XINT (arg1); - f2 = (FLOATP (arg2)) ? float_data (XFLOAT (arg2)) : XINT (arg2); - /* Really should check for overflow, too */ - if (f1 == 0.0 && f2 == 0.0) - f1 = 1.0; + { + double f1 = extract_float (arg1); + double f2 = extract_float (arg2); + /* Really should check for overflow, too */ + if (f1 == 0.0 && f2 == 0.0) + f1 = 1.0; # ifdef FLOAT_CHECK_DOMAIN - else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2))) - domain_error2 ("expt", arg1, arg2); + else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2))) + domain_error2 ("expt", arg1, arg2); # endif /* FLOAT_CHECK_DOMAIN */ - IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2); - return make_float (f1); -#else /* !LISP_FLOAT_TYPE */ - abort (); + IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2); + return make_float (f1); + } +#else + CHECK_INT_OR_FLOAT (arg1); + CHECK_INT_OR_FLOAT (arg2); + return Fexpt (arg1, arg2); #endif /* LISP_FLOAT_TYPE */ } @@ -651,21 +654,19 @@ */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - IN_FLOAT (arg = make_float ((double) fabs (float_data (XFLOAT (arg)))), - "abs", arg); - return (arg); - } - else + { + IN_FLOAT (arg = make_float (fabs (XFLOAT_DATA (arg))), + "abs", arg); + return arg; + } #endif /* LISP_FLOAT_TYPE */ - if (XINT (arg) < 0) - return (make_int (- XINT (arg))); - else - return (arg); + + if (INTP (arg)) + return (XINT (arg) >= 0) ? arg : make_int (- XINT (arg)); + + return Fabs (wrong_type_argument (arg, Qnumberp)); } #ifdef LISP_FLOAT_TYPE @@ -674,12 +675,13 @@ */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - if (INTP (arg)) return make_float ((double) XINT (arg)); - else /* give 'em the same float back */ + + if (FLOATP (arg)) /* give 'em the same float back */ return arg; + + return Ffloat (wrong_type_argument (arg, Qnumberp)); } #endif /* LISP_FLOAT_TYPE */ @@ -743,18 +745,19 @@ */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - double d; - IN_FLOAT ((d = ceil (float_data (XFLOAT (arg)))), "ceiling", arg); - return (float_to_int (d, "ceiling", arg, Qunbound)); - } + { + double d; + IN_FLOAT ((d = ceil (XFLOAT_DATA (arg))), "ceiling", arg); + return (float_to_int (d, "ceiling", arg, Qunbound)); + } #endif /* LISP_FLOAT_TYPE */ - return arg; + if (INTP (arg)) + return arg; + + return Fceiling (wrong_type_argument (arg, Qnumberp)); } @@ -775,10 +778,9 @@ #ifdef LISP_FLOAT_TYPE if (FLOATP (arg) || FLOATP (divisor)) { - double f1, f2; + double f1 = extract_float (arg); + double f2 = extract_float (divisor); - f1 = ((FLOATP (arg)) ? float_data (XFLOAT (arg)) : XINT (arg)); - f2 = ((FLOATP (divisor)) ? float_data (XFLOAT (divisor)) : XINT (divisor)); if (f2 == 0) Fsignal (Qarith_error, Qnil); @@ -804,11 +806,11 @@ #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - double d; - IN_FLOAT ((d = floor (float_data (XFLOAT (arg)))), "floor", arg); - return (float_to_int (d, "floor", arg, Qunbound)); - } + { + double d; + IN_FLOAT ((d = floor (XFLOAT_DATA (arg))), "floor", arg); + return (float_to_int (d, "floor", arg, Qunbound)); + } #endif /* LISP_FLOAT_TYPE */ return arg; @@ -819,19 +821,20 @@ */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - { - double d; - /* Screw the prevailing rounding mode. */ - IN_FLOAT ((d = rint (float_data (XFLOAT (arg)))), "round", arg); - return (float_to_int (d, "round", arg, Qunbound)); - } + { + double d; + /* Screw the prevailing rounding mode. */ + IN_FLOAT ((d = rint (XFLOAT_DATA (arg))), "round", arg); + return (float_to_int (d, "round", arg, Qunbound)); + } #endif /* LISP_FLOAT_TYPE */ - return arg; + if (INTP (arg)) + return arg; + + return Fround (wrong_type_argument (arg, Qnumberp)); } DEFUN ("truncate", Ftruncate, 1, 1, 0, /* @@ -840,15 +843,15 @@ */ (arg)) { - CHECK_INT_OR_FLOAT (arg); - #ifdef LISP_FLOAT_TYPE if (FLOATP (arg)) - return (float_to_int (float_data (XFLOAT (arg)), - "truncate", arg, Qunbound)); + return float_to_int (XFLOAT_DATA (arg), "truncate", arg, Qunbound); #endif /* LISP_FLOAT_TYPE */ - return arg; + if (INTP (arg)) + return arg; + + return Ftruncate (wrong_type_argument (arg, Qnumberp)); } /* Float-rounding functions. */ diff -r 76b7d63099ad -r 8626e4521993 src/fns.c --- a/src/fns.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/fns.c Mon Aug 13 11:07:10 2007 +0200 @@ -43,7 +43,6 @@ #include "buffer.h" #include "bytecode.h" -#include "commands.h" #include "device.h" #include "events.h" #include "extents.h" @@ -91,10 +90,10 @@ } static int -bit_vector_equal (Lisp_Object o1, Lisp_Object o2, int depth) +bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (o1); - struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (o2); + struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); + struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); return ((bit_vector_length (v1) == bit_vector_length (v2)) && !memcmp (v1->bits, v2->bits, @@ -178,10 +177,10 @@ return XINT (Flength (seq)); else { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (seq); - - return (b->flags.interactivep ? COMPILED_INTERACTIVE : - b->flags.domainp ? COMPILED_DOMAIN : + struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); + + return (f->flags.interactivep ? COMPILED_INTERACTIVE : + f->flags.domainp ? COMPILED_DOMAIN : COMPILED_DOC_STRING) + 1; } @@ -209,16 +208,9 @@ return make_int (XSTRING_CHAR_LENGTH (sequence)); else if (CONSP (sequence)) { - Lisp_Object tail; - int i = 0; - - EXTERNAL_LIST_LOOP (tail, sequence) - { - QUIT; - i++; - } - - return make_int (i); + int len; + GET_EXTERNAL_LIST_LENGTH (sequence, len); + return make_int (len); } else if (VECTORP (sequence)) return make_int (XVECTOR_LENGTH (sequence)); @@ -234,9 +226,6 @@ } } -/* This does not check for quits. That is safe - since it must terminate. */ - DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* Return the length of a list, but avoid error or infinite loop. This function never gets an error. If LIST is not really a list, @@ -245,17 +234,15 @@ */ (list)) { - Lisp_Object halftail = list; /* Used to detect circular lists. */ - Lisp_Object tail; - int len = 0; - - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object hare, tortoise; + int len; + + for (hare = tortoise = list, len = 0; + CONSP (hare) && (! EQ (hare, tortoise) || len == 0); + hare = XCDR (hare), len++) { - if (EQ (tail, halftail) && len != 0) - break; - len++; - if ((len & 1) == 0) - halftail = XCDR (halftail); + if (len & 1) + tortoise = XCDR (tortoise); } return make_int (len); @@ -511,38 +498,65 @@ 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; - - 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); - - check_losing_bytecode ("copy-sequence", arg); - arg = wrong_type_argument (Qsequencep, arg); + if (NILP (list)) return list; + if (CONSP (list)) return copy_list (list); + + list = wrong_type_argument (Qlistp, list); + goto again; +} + +DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* +Return a copy of list, vector, bit vector or string SEQUENCE. +The elements of a list or vector are not copied; they are shared +with the original. SEQUENCE may be a dotted list. +*/ + (sequence)) +{ + again: + if (NILP (sequence)) return sequence; + if (CONSP (sequence)) return copy_list (sequence); + if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); + if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); + if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); + + check_losing_bytecode ("copy-sequence", sequence); + sequence = wrong_type_argument (Qsequencep, sequence); goto again; } @@ -871,7 +885,6 @@ Lisp_Object val; CHECK_STRING (string); - /* Historically, FROM could not be omitted. Whatever ... */ CHECK_INT (from); get_string_range_char (string, from, to, &ccfr, &ccto, GB_HISTORICAL_STRING_BEHAVIOR); @@ -1023,9 +1036,9 @@ args_out_of_range (sequence, n); #endif } - else if (STRINGP (sequence) - || VECTORP (sequence) - || BIT_VECTORP (sequence)) + else if (STRINGP (sequence) || + VECTORP (sequence) || + BIT_VECTORP (sequence)) return Faref (sequence, n); #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (sequence)) @@ -1038,24 +1051,24 @@ } /* Utter perversity */ { - struct Lisp_Compiled_Function *b = XCOMPILED_FUNCTION (sequence); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence); switch (idx) { case COMPILED_ARGLIST: - return b->arglist; - case COMPILED_BYTECODE: - return b->bytecodes; + return compiled_function_arglist (f); + case COMPILED_INSTRUCTIONS: + return compiled_function_instructions (f); case COMPILED_CONSTANTS: - return b->constants; + return compiled_function_constants (f); case COMPILED_STACK_DEPTH: - return make_int (b->maxdepth); + return compiled_function_stack_depth (f); case COMPILED_DOC_STRING: - return compiled_function_documentation (b); + return compiled_function_documentation (f); case COMPILED_DOMAIN: - return compiled_function_domain (b); + return compiled_function_domain (f); case COMPILED_INTERACTIVE: - if (b->flags.interactivep) - return compiled_function_interactive (b); + if (f->flags.interactivep) + return compiled_function_interactive (f); /* if we return nil, can't tell interactive with no args from noninteractive. */ goto lose; @@ -1073,19 +1086,126 @@ } } +DEFUN ("last", Flast, 1, 2, 0, /* +Return the tail of list LIST, of length N (default 1). +LIST may be a dotted list, but not a circular list. +Optional argument N must be a non-negative integer. +If N is zero, then the atom that terminates the list is returned. +If N is greater than the length of LIST, then LIST itself is returned. +*/ + (list, n)) +{ + int int_n, count; + Lisp_Object retval, tortoise, hare; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + for (retval = tortoise = hare = list, count = 0; + CONSP (hare); + hare = XCDR (hare), + (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), + count++) + { + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (hare, tortoise)) + signal_circular_list_error (list); + } + + return retval; +} + +DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* +Modify LIST to remove the last N (default 1) elements. +If LIST has N or fewer elements, nil is returned and LIST is unmodified. +*/ + (list, n)) +{ + int int_n; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + { + Lisp_Object last_cons = list; + + EXTERNAL_LIST_LOOP_1 (list) + { + if (int_n-- < 0) + last_cons = XCDR (last_cons); + } + + if (int_n >= 0) + return Qnil; + + XCDR (last_cons) = Qnil; + return list; + } +} + +DEFUN ("butlast", Fbutlast, 1, 2, 0, /* +Return a copy of LIST with the last N (default 1) elements removed. +If LIST has N or fewer elements, nil is returned. +*/ + (list, n)) +{ + int int_n; + + CHECK_LIST (list); + + if (NILP (n)) + int_n = 1; + else + { + CHECK_NATNUM (n); + int_n = XINT (n); + } + + { + Lisp_Object retval = Qnil; + Lisp_Object tail = list; + + EXTERNAL_LIST_LOOP_1 (list) + { + if (--int_n < 0) + { + retval = Fcons (XCAR (tail), retval); + tail = XCDR (tail); + } + } + + return Fnreverse (retval); + } +} + DEFUN ("member", Fmember, 2, 2, 0, /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. The value is actually the tail of LIST whose car is ELT. */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - CONCHECK_CONS (tail); - if (internal_equal (elt, XCAR (tail), 0)) + if (internal_equal (elt, list_elt, 0)) return tail; - QUIT; } return Qnil; } @@ -1098,13 +1218,11 @@ */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - CONCHECK_CONS (tail); - if (internal_old_equal (elt, XCAR (tail), 0)) + if (internal_old_equal (elt, list_elt, 0)) return tail; - QUIT; } return Qnil; } @@ -1115,14 +1233,11 @@ */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) return tail; - QUIT; } return Qnil; } @@ -1135,14 +1250,11 @@ */ (elt, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object list_elt, tail; + EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem)) + if (HACKEQ_UNSAFE (elt, list_elt)) return tail; - QUIT; } return Qnil; } @@ -1150,11 +1262,10 @@ Lisp_Object memq_no_quit (Lisp_Object elt, Lisp_Object list) { - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object list_elt, tail; + LIST_LOOP_3 (list_elt, list, tail) { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) return tail; } return Qnil; @@ -1167,15 +1278,11 @@ (key, list)) { /* This function can GC. */ - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (XCAR (elt), key, 0)) + if (internal_equal (key, elt_car, 0)) return elt; - QUIT; } return Qnil; } @@ -1187,15 +1294,11 @@ (key, list)) { /* This function can GC. */ - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_old_equal (XCAR (elt), key, 0)) + if (internal_old_equal (key, elt_car, 0)) return elt; - QUIT; } return Qnil; } @@ -1215,15 +1318,11 @@ */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) return elt; - QUIT; } return Qnil; } @@ -1237,15 +1336,11 @@ */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), HACKEQ_UNSAFE (key, tem))) + if (HACKEQ_UNSAFE (key, elt_car)) return elt; - QUIT; } return Qnil; } @@ -1257,13 +1352,12 @@ assq_no_quit (Lisp_Object key, Lisp_Object list) { /* This cannot GC. */ - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object elt; + LIST_LOOP_2 (elt, list) { - REGISTER Lisp_Object tem, elt; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - return elt; + Lisp_Object elt_car = XCAR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) + return elt; } return Qnil; } @@ -1274,15 +1368,11 @@ */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (XCDR (elt), key, 0)) + if (internal_equal (key, elt_cdr, 0)) return elt; - QUIT; } return Qnil; } @@ -1293,15 +1383,11 @@ */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_old_equal (XCDR (elt), key, 0)) + if (internal_old_equal (key, elt_cdr, 0)) return elt; - QUIT; } return Qnil; } @@ -1312,15 +1398,11 @@ */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) return elt; - QUIT; } return Qnil; } @@ -1331,28 +1413,25 @@ */ (key, list)) { - REGISTER Lisp_Object tail; - LIST_LOOP (tail, list) + Lisp_Object elt, elt_car, elt_cdr; + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), HACKEQ_UNSAFE (key, tem))) + if (HACKEQ_UNSAFE (key, elt_cdr)) return elt; - QUIT; } return Qnil; } +/* Like Frassq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ Lisp_Object rassq_no_quit (Lisp_Object key, Lisp_Object list) { - REGISTER Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object elt; + LIST_LOOP_2 (elt, list) { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) + Lisp_Object elt_cdr = XCDR (elt); + if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) return elt; } return Qnil; @@ -1369,24 +1448,9 @@ */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - CONCHECK_CONS (tail); - if (internal_equal (elt, XCAR (tail), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_equal (elt, list_elt, 0))); return list; } @@ -1399,24 +1463,9 @@ */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - CONCHECK_CONS (tail); - if (internal_old_equal (elt, XCAR (tail), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (internal_old_equal (elt, list_elt, 0))); return list; } @@ -1429,25 +1478,9 @@ */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; } @@ -1460,50 +1493,21 @@ */ (elt, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object tem; - CONCHECK_CONS (tail); - if (tem = XCAR (tail), HACKEQ_UNSAFE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object list_elt; + EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, + (HACKEQ_UNSAFE (elt, list_elt))); return list; } -/* no quit, no errors; be careful */ +/* Like Fdelq, but caller must ensure that LIST is properly + nil-terminated and ebola-free. */ Lisp_Object delq_no_quit (Lisp_Object elt, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object list_elt; + LIST_LOOP_DELETE_IF (list_elt, list, + (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; } @@ -1519,26 +1523,24 @@ { REGISTER Lisp_Object tail = list; REGISTER Lisp_Object prev = Qnil; - struct Lisp_Cons *cons_to_free = NULL; - - while (CONSP (tail)) + + while (!NILP (tail)) { - REGISTER Lisp_Object tem; - if (tem = XCAR (tail), EQ_WITH_EBOLA_NOTICE (elt, tem)) + REGISTER Lisp_Object tem = XCAR (tail); + if (EQ (elt, tem)) { + Lisp_Object cons_to_free = tail; if (NILP (prev)) list = XCDR (tail); else XCDR (prev) = XCDR (tail); - cons_to_free = XCONS (tail); + tail = XCDR (tail); + free_cons (XCONS (cons_to_free)); } else - prev = tail; - tail = XCDR (tail); - if (cons_to_free) { - free_cons (cons_to_free); - cons_to_free = NULL; + prev = tail; + tail = XCDR (tail); } } return list; @@ -1553,26 +1555,10 @@ */ (key, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (key, XCAR (elt), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + internal_equal (key, XCAR (elt), 0))); return list; } @@ -1593,26 +1579,10 @@ */ (key, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); return list; } @@ -1621,24 +1591,10 @@ Lisp_Object remassq_no_quit (Lisp_Object key, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCAR (elt), EQ_WITH_EBOLA_NOTICE (key, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object elt; + LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); return list; } @@ -1651,26 +1607,10 @@ */ (value, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && internal_equal (value, XCDR (elt), 0)) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + internal_equal (value, XCDR (elt), 0))); return list; } @@ -1683,52 +1623,21 @@ */ (value, list)) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (!NILP (tail)) - { - REGISTER Lisp_Object elt, tem; - CONCHECK_CONS (tail); - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - QUIT; - } + Lisp_Object elt; + EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); return list; } -/* no quit, no errors; be careful */ - +/* Like Fremrassq, fast and unsafe; be careful */ Lisp_Object remrassq_no_quit (Lisp_Object value, Lisp_Object list) { - REGISTER Lisp_Object tail = list; - REGISTER Lisp_Object prev = Qnil; - - while (CONSP (tail)) - { - REGISTER Lisp_Object elt, tem; - elt = XCAR (tail); - if (CONSP (elt) && (tem = XCDR (elt), EQ_WITH_EBOLA_NOTICE (value, tem))) - { - if (NILP (prev)) - list = XCDR (tail); - else - XCDR (prev) = XCDR (tail); - } - else - prev = tail; - tail = XCDR (tail); - } + Lisp_Object elt; + LIST_LOOP_DELETE_IF (elt, list, + (CONSP (elt) && + EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); return list; } @@ -1748,7 +1657,6 @@ while (!NILP (tail)) { REGISTER Lisp_Object next; - QUIT; CONCHECK_CONS (tail); next = XCDR (tail); XCDR (tail) = prev; @@ -1765,17 +1673,13 @@ */ (list)) { - REGISTER Lisp_Object tail; - Lisp_Object new = Qnil; - - for (tail = list; CONSP (tail); tail = XCDR (tail)) + Lisp_Object reversed_list = Qnil; + Lisp_Object elt; + EXTERNAL_LIST_LOOP_2 (elt, list) { - new = Fcons (XCAR (tail), new); - QUIT; + reversed_list = Fcons (elt, reversed_list); } - if (!NILP (tail)) - dead_wrong_type_argument (Qlistp, tail); - return new; + return reversed_list; } static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2, @@ -2081,13 +1985,12 @@ Lisp_Object internal_plist_get (Lisp_Object plist, Lisp_Object property) { - Lisp_Object tail = plist; - - for (; !NILP (tail); tail = XCDR (XCDR (tail))) + Lisp_Object tail; + + for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) { - struct Lisp_Cons *c = XCONS (tail); - if (EQ (c->car, property)) - return XCAR (c->cdr); + if (EQ (XCAR (tail), property)) + return XCAR (XCDR (tail)); } return Qunbound; @@ -2117,26 +2020,22 @@ 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; - } - - for (tail = XCDR (tail); !NILP (XCDR (tail)); + Lisp_Object tail, prev; + + for (tail = *plist, prev = Qnil; + !NILP (tail); tail = XCDR (XCDR (tail))) { - struct Lisp_Cons *c = XCONS (tail); - if (EQ (XCAR (c->cdr), property)) + if (EQ (XCAR (tail), property)) { - c->cdr = XCDR (XCDR (c->cdr)); + if (NILP (prev)) + *plist = XCDR (XCDR (tail)); + else + XCDR (XCDR (prev)) = XCDR (XCDR (tail)); return 1; } + else + prev = tail; } return 0; @@ -2211,7 +2110,7 @@ Lisp_Object *tortsave = *tortoise; /* Note that our "fixing" may be more brutal than necessary, - but it's the user's own problem, not ours. if they went in and + but it's the user's own problem, not ours, if they went in and manually fucked up a plist. */ for (i = 0; i < 2; i++) @@ -2385,9 +2284,7 @@ (plist, prop, default_)) { Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME); - if (UNBOUNDP (val)) - return default_; - return val; + return UNBOUNDP (val) ? default_ : val; } DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* @@ -2423,7 +2320,8 @@ */ (plist, prop)) { - return UNBOUNDP (Fplist_get (plist, prop, Qunbound)) ? Qnil : Qt; + Lisp_Object val = Fplist_get (plist, prop, Qunbound); + return UNBOUNDP (val) ? Qnil : Qt; } DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* @@ -2512,7 +2410,8 @@ /* external_remprop returns 1 if it removed any property. We have to loop till it didn't remove anything, in case the property occurs many times. */ - while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)); + while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) + DO_NOTHING; plist = Fcdr (next); } @@ -2523,7 +2422,7 @@ Extract a value from a lax property list. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. This function returns the value corresponding to the given PROP, or DEFAULT if PROP is not one of the properties on the list. @@ -2539,7 +2438,7 @@ DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* Change value in LAX-PLIST of PROP to VAL. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. PROP is usually a symbol and VAL is any object. If PROP is already a property on the list, its value is set to VAL, otherwise the new PROP VAL pair is added. The new plist @@ -2555,7 +2454,7 @@ DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* Remove from LAX-PLIST the property PROP and its value. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. PROP is usually a symbol. The new plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be sure to use the new value. The LAX-PLIST is modified by side effects. @@ -2569,7 +2468,7 @@ DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* Return t if PROP has a value specified in LAX-PLIST. LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparions between properties is done +VALUE1 PROP2 VALUE2...), where comparisons between properties is done using `equal' instead of `eq'. */ (lax_plist, prop)) @@ -2612,7 +2511,8 @@ /* external_remprop returns 1 if it removed any property. We have to loop till it didn't remove anything, in case the property occurs many times. */ - while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)); + while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) + DO_NOTHING; lax_plist = Fcdr (next); } @@ -2733,37 +2633,35 @@ */ (object, propname, default_)) { - Lisp_Object val; - /* Various places in emacs call Fget() and expect it not to quit, so don't quit. */ /* It's easiest to treat symbols specially because they may not be an lrecord */ if (SYMBOLP (object)) - val = symbol_getprop (object, propname, default_); + return symbol_getprop (object, propname, default_); else if (STRINGP (object)) - val = string_getprop (XSTRING (object), propname, default_); + return string_getprop (XSTRING (object), propname, default_); else if (LRECORDP (object)) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->getprop) - { - val = (imp->getprop) (object, propname); - if (UNBOUNDP (val)) - val = default_; - } - else + CONST struct lrecord_implementation *imp + = XRECORD_LHEADER_IMPLEMENTATION (object); + if (!imp->getprop) goto noprops; + + { + Lisp_Object val = (imp->getprop) (object, propname); + if (UNBOUNDP (val)) + val = default_; + return val; + } } else { noprops: signal_simple_error ("Object type has no properties", object); + return Qnil; /* Not reached */ } - - return val; } DEFUN ("put", Fput, 3, 3, 0, /* @@ -2884,7 +2782,7 @@ int -internal_equal (Lisp_Object o1, Lisp_Object o2, int depth) +internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); @@ -2892,28 +2790,28 @@ do_cdr: #endif QUIT; - if (EQ_WITH_EBOLA_NOTICE (o1, o2)) + if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ - else if (XTYPE (o1) != XTYPE (o2)) + if (XTYPE (obj1) != XTYPE (obj2)) return 0; #ifndef LRECORD_CONS - else if (CONSP (o1)) + if (CONSP (obj1)) { - if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1)) + if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1)) return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); + obj1 = XCDR (obj1); + obj2 = XCDR (obj2); goto do_cdr; } #endif #ifndef LRECORD_VECTOR - else if (VECTORP (o1)) + if (VECTORP (obj1)) { - Lisp_Object *v1 = XVECTOR_DATA (o1); - Lisp_Object *v2 = XVECTOR_DATA (o2); - int len = XVECTOR_LENGTH (o1); - if (len != XVECTOR_LENGTH (o2)) + Lisp_Object *v1 = XVECTOR_DATA (obj1); + Lisp_Object *v2 = XVECTOR_DATA (obj2); + int len = XVECTOR_LENGTH (obj1); + if (len != XVECTOR_LENGTH (obj2)) return 0; while (len--) if (!internal_equal (*v1++, *v2++, depth + 1)) @@ -2922,25 +2820,22 @@ } #endif #ifndef LRECORD_STRING - else if (STRINGP (o1)) + if (STRINGP (obj1)) { Bytecount len; - return (((len = XSTRING_LENGTH (o1)) == XSTRING_LENGTH (o2)) && - !memcmp (XSTRING_DATA (o1), XSTRING_DATA (o2), len)); + return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && + !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); } #endif - else if (LRECORDP (o1)) + if (LRECORDP (obj1)) { CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1), - *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2); - if (imp1 != imp2) - return 0; - else if (imp1->equal == 0) + *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), + *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); + + return (imp1 == imp2) && /* EQ-ness of the objects was noticed above */ - return 0; - else - return (imp1->equal) (o1, o2, depth); + (imp1->equal && (imp1->equal) (obj1, obj2, depth)); } return 0; @@ -2952,7 +2847,7 @@ but that seems unlikely. */ static int -internal_old_equal (Lisp_Object o1, Lisp_Object o2, int depth) +internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); @@ -2960,64 +2855,37 @@ 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)) + Lisp_Object *v1 = XVECTOR_DATA (obj1); + Lisp_Object *v2 = XVECTOR_DATA (obj2); + int len = XVECTOR_LENGTH (obj1); + if (len != XVECTOR_LENGTH (obj2)) return 0; - for (indice = 0; indice < len; indice++) - { - if (!internal_old_equal (XVECTOR_DATA (o1) [indice], - XVECTOR_DATA (o2) [indice], - depth + 1)) - return 0; - } + while (len--) + if (!internal_old_equal (*v1++, *v2++, 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)) - return 0; - return 1; - } -#endif - else if (LRECORDP (o1)) - { - CONST struct lrecord_implementation - *imp1 = XRECORD_LHEADER_IMPLEMENTATION (o1), - *imp2 = XRECORD_LHEADER_IMPLEMENTATION (o2); - if (imp1 != imp2) - return 0; - else if (imp1->equal == 0) - /* EQ-ness of the objects was noticed above */ - return 0; - else - return (imp1->equal) (o1, o2, depth); - } - - return 0; + + return internal_equal (obj1, obj2, depth); } DEFUN ("equal", Fequal, 2, 2, 0, /* @@ -3027,9 +2895,9 @@ Vectors and strings are compared element by element. Numbers are compared by value. Symbols must match exactly. */ - (o1, o2)) + (obj1, obj2)) { - return internal_equal (o1, o2, 0) ? Qt : Qnil; + return internal_equal (obj1, obj2, 0) ? Qt : Qnil; } DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* @@ -3041,9 +2909,9 @@ This function is provided only for byte-code compatibility with v19. Do not use it. */ - (o1, o2)) + (obj1, obj2)) { - return internal_old_equal (o1, o2, 0) ? Qt : Qnil; + return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil; } @@ -3095,12 +2963,53 @@ } Lisp_Object -nconc2 (Lisp_Object s1, Lisp_Object s2) +nconc2 (Lisp_Object arg1, Lisp_Object arg2) { Lisp_Object args[2]; - args[0] = s1; - args[1] = s2; - return Fnconc (2, args); + struct gcpro gcpro1; + args[0] = arg1; + args[1] = arg2; + + GCPRO1 (args[0]); + gcpro1.nvars = 2; + + RETURN_UNGCPRO (bytecode_nconc2 (args)); +} + +Lisp_Object +bytecode_nconc2 (Lisp_Object *args) +{ + retry: + + if (CONSP (args[0])) + { + /* (setcdr (last args[0]) args[1]) */ + Lisp_Object tortoise, hare; + int count; + + for (hare = tortoise = args[0], count = 0; + CONSP (XCDR (hare)); + hare = XCDR (hare), count++) + { + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (hare, tortoise)) + signal_circular_list_error (args[0]); + } + XCDR (hare) = args[1]; + return args[0]; + } + else if (NILP (args[0])) + { + return args[1]; + } + else + { + args[0] = wrong_type_argument (args[0], Qlistp); + goto retry; + } } DEFUN ("nconc", Fnconc, 0, MANY, 0, /* @@ -3131,22 +3040,32 @@ Lisp_Object val = args[argnum]; if (CONSP (val)) { - /* Found the first cons, which will be our return value. */ - Lisp_Object last = val; + /* `val' is the first cons, which will be our return value. */ + /* `last_cons' will be the cons cell to mutate. */ + Lisp_Object last_cons = val; + Lisp_Object tortoise = val; for (argnum++; argnum < nargs; argnum++) { Lisp_Object next = args[argnum]; - redo: + retry: if (CONSP (next) || argnum == nargs -1) { /* (setcdr (last val) next) */ - while (CONSP (XCDR (last))) + int count; + + for (count = 0; + CONSP (XCDR (last_cons)); + last_cons = XCDR (last_cons), count++) { - last = XCDR (last); - QUIT; + if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = XCDR (tortoise); + if (EQ (last_cons, tortoise)) + signal_circular_list_error (args[argnum-1]); } - XCDR (last) = next; + XCDR (last_cons) = next; } else if (NILP (next)) { @@ -3155,7 +3074,7 @@ else { next = wrong_type_argument (next, Qlistp); - goto redo; + goto retry; } } RETURN_UNGCPRO (val); @@ -3771,20 +3690,20 @@ ways these functions can blow up, and we don't want to have memory leaks in those cases. */ #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \ - if ((len) > MAX_ALLOCA) \ + size_t XOA_len = (len); \ + if (XOA_len > MAX_ALLOCA) \ { \ - ptr = (type *)xmalloc ((len) * sizeof (type)); \ - speccount = specpdl_depth (); \ + ptr = xnew_array (type, XOA_len); \ record_unwind_protect (free_malloced_ptr, \ make_opaque_ptr ((void *)ptr)); \ } \ else \ - ptr = alloca_array (type, len); \ + ptr = alloca_array (type, XOA_len); \ } while (0) -#define XMALLOC_UNBIND(ptr, len) do { \ - if ((len) > MAX_ALLOCA) \ - unbind_to (speccount, Qnil); \ +#define XMALLOC_UNBIND(ptr, len, speccount) do { \ + if ((len) > MAX_ALLOCA) \ + unbind_to (speccount, Qnil); \ } while (0) DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* @@ -3801,9 +3720,10 @@ struct buffer *buf = current_buffer; Bufpos begv, zv, old_pt = BUF_PT (buf); Lisp_Object input; - int speccount; + int speccount = specpdl_depth(); get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + barf_if_buffer_read_only (buf, begv, zv); /* We need to allocate enough room for encoding the text. We need 33 1/3% more space, plus a newline every 76 @@ -3825,7 +3745,7 @@ /* Now we have encoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); - XMALLOC_UNBIND (encoded, allength); + XMALLOC_UNBIND (encoded, allength, speccount); buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); /* Simulate FSF Emacs: if point was in the region, place it at the @@ -3846,7 +3766,7 @@ Bytind encoded_length; Bufbyte *encoded; Lisp_Object input, result; - int speccount; + int speccount = specpdl_depth(); CHECK_STRING (string); @@ -3860,7 +3780,7 @@ abort (); Lstream_delete (XLSTREAM (input)); result = make_string (encoded, encoded_length); - XMALLOC_UNBIND (encoded, allength); + XMALLOC_UNBIND (encoded, allength, speccount); return result; } @@ -3877,9 +3797,11 @@ Bytind decoded_length; Charcount length, cc_decoded_length; Lisp_Object input; - int speccount; + int speccount = specpdl_depth(); get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + barf_if_buffer_read_only (buf, begv, zv); + length = zv - begv; input = make_lisp_buffer_input_stream (buf, begv, zv, 0); @@ -3893,7 +3815,7 @@ if (decoded_length < 0) { /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return Qnil; } @@ -3901,7 +3823,7 @@ and delete the old. (Insert first in order to preserve markers.) */ BUF_SET_PT (buf, begv); buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); buffer_delete_range (buf, begv + cc_decoded_length, zv + cc_decoded_length, 0); @@ -3922,7 +3844,7 @@ Bytind decoded_length; Charcount length, cc_decoded_length; Lisp_Object input, result; - int speccount; + int speccount = specpdl_depth(); CHECK_STRING (string); @@ -3939,12 +3861,13 @@ if (decoded_length < 0) { + /* The decoding wasn't possible. */ + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return Qnil; - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); } result = make_string (decoded, decoded_length); - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN); + XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return result; } @@ -3968,6 +3891,7 @@ DEFSUBR (Fconcat); DEFSUBR (Fvconcat); DEFSUBR (Fbvconcat); + DEFSUBR (Fcopy_list); DEFSUBR (Fcopy_sequence); DEFSUBR (Fcopy_alist); DEFSUBR (Fcopy_tree); @@ -3976,6 +3900,9 @@ DEFSUBR (Fnthcdr); DEFSUBR (Fnth); DEFSUBR (Felt); + DEFSUBR (Flast); + DEFSUBR (Fbutlast); + DEFSUBR (Fnbutlast); DEFSUBR (Fmember); DEFSUBR (Fold_member); DEFSUBR (Fmemq); diff -r 76b7d63099ad -r 8626e4521993 src/frame-msw.c --- a/src/frame-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/frame-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -126,9 +126,9 @@ FRAME_MSWINDOWS_DATA(f)->ignore_next_lbutton_up = 0; FRAME_MSWINDOWS_DATA(f)->ignore_next_rbutton_up = 0; FRAME_MSWINDOWS_DATA(f)->sizing = 0; - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil; #ifdef HAVE_TOOLBARS - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE(f) = Fmake_hashtable (make_int (50), + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f) = Fmake_hash_table (make_int (50), Qequal); #endif @@ -234,8 +234,8 @@ frame is created, it will never be displayed, except for hollow border, unless we start pumping messages. Load progress messages show in the bottom of the hollow frame, which is ugly. - We redipsplay the initial frame here, so modeline and root window - backgorund show. + We redisplay the initial frame here, so modeline and root window + background show. */ if (first_on_console) redisplay (); @@ -244,9 +244,9 @@ static void mswindows_mark_frame (struct frame *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FRAME_MSWINDOWS_MENU_HASHTABLE (f))); + markobj (FRAME_MSWINDOWS_MENU_HASH_TABLE (f)); #ifdef HAVE_TOOLBARS - ((markobj) (FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f))); + markobj (FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f)); #endif } @@ -322,7 +322,7 @@ RECT rc_me, rc_other, rc_temp; HWND hwnd = FRAME_MSWINDOWS_HANDLE(f); - /* We test against not a whole window rectangle, only agaist its + /* We test against not a whole window rectangle, only against its client part. So, if non-client are is covered and client area is not, we return true. */ GetClientRect (hwnd, &rc_me); diff -r 76b7d63099ad -r 8626e4521993 src/frame-tty.c --- a/src/frame-tty.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/frame-tty.c Mon Aug 13 11:07:10 2007 +0200 @@ -155,13 +155,11 @@ static void tty_raise_frame_no_select (struct frame *f) { - struct frame *o; - Lisp_Object tail; - - LIST_LOOP (tail, DEVICE_FRAME_LIST (XDEVICE (FRAME_DEVICE (f)))) + Lisp_Object frame; + LIST_LOOP_2 (frame, DEVICE_FRAME_LIST (XDEVICE (FRAME_DEVICE (f)))) { - o = XFRAME (XCAR (tail)); - if (o != f && FRAME_REPAINT_P(o)) + struct frame *o = XFRAME (frame); + if (o != f && FRAME_REPAINT_P (o)) { tty_make_frame_hidden (o); break; @@ -216,7 +214,7 @@ } /************************************************************************/ -/* initialization */ +/* initialization */ /************************************************************************/ void diff -r 76b7d63099ad -r 8626e4521993 src/frame-x.c --- a/src/frame-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/frame-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -278,8 +278,7 @@ int need_delete = 1; int need_focus = 1; - if (!XtIsWMShell (widget)) - abort (); + assert (XtIsWMShell (widget)); { Atom type, *atoms = 0; @@ -996,7 +995,7 @@ { for (i = 0; i < dragData->numItems; i++) { - XtFree(dragData->data.buffers[i].bp); + XtFree((char *) dragData->data.buffers[i].bp); if (dragData->data.buffers[i].name) XtFree(dragData->data.buffers[i].name); } @@ -1151,7 +1150,7 @@ numItems++; item = XCDR (item); } - + if (numItems) { /* @@ -1160,7 +1159,7 @@ */ Ctext = (char *)xmalloc (textlen+1); Ctext[0] = 0; - + item = dragdata; while (!NILP (item)) { @@ -1176,12 +1175,12 @@ item = XCDR (item); } Ctext[pos] = 0; - + dnd_convert_cb_rec[0].callback = x_cde_convert_callback; dnd_convert_cb_rec[0].closure = (XtPointer) Ctext; dnd_convert_cb_rec[1].callback = NULL; dnd_convert_cb_rec[1].closure = NULL; - + dnd_destroy_cb_rec[0].callback = x_cde_destroy_callback; dnd_destroy_cb_rec[0].closure = (XtPointer) Ctext; dnd_destroy_cb_rec[1].callback = NULL; @@ -1198,7 +1197,7 @@ } UNGCPRO; - + return numItems?Qt:Qnil; } @@ -1268,7 +1267,7 @@ /* what, if the data is no text, and how can I tell it? */ l_data = Fcons ( list3 ( list1 ( make_string ((Bufbyte *)"text/plain", 10) ), make_string ((Bufbyte *)"8bit", 4), - make_string ((Bufbyte *)transferInfo->dropData->data.buffers[ii].bp, + make_string ((Bufbyte *)transferInfo->dropData->data.buffers[ii].bp, transferInfo->dropData->data.buffers[ii].size) ), l_data ); } @@ -1279,7 +1278,7 @@ enqueue=0; /* The Problem: no button and mods from CDE... */ - if (enqueue) + if (enqueue) enqueue_misc_user_event_pos ( frame, Qdragdrop_drop_dispatch, Fcons (l_type, l_data), 0 /* this is the button */, @@ -1361,15 +1360,13 @@ if (!STRINGP (data)) return Qnil; - /* and whats with MULE data ??? */ + /* and what's with MULE data ??? */ dnd_data = (char *)XSTRING_DATA (data); dnd_len = XSTRING_LENGTH (data) + 1; /* the zero */ } - /* - * not so cross hack that converts a emacs event back to a XEvent - */ + /* not so gross hack that converts an emacs event back to a XEvent */ x_event.xbutton.type = ButtonPress; x_event.xbutton.send_event = False; @@ -1923,9 +1920,9 @@ XtSetArg (al[ac], XtNinput, True); ac++; XtSetArg (al[ac], XtNminWidthCells, 10); ac++; XtSetArg (al[ac], XtNminHeightCells, 1); ac++; - XtSetArg (al[ac], XtNvisual, visual); ac++; - XtSetArg (al[ac], XtNdepth, depth); ac++; - XtSetArg (al[ac], XtNcolormap, cmap); ac++; + XtSetArg (al[ac], XtNvisual, visual); ac++; + XtSetArg (al[ac], XtNdepth, depth); ac++; + XtSetArg (al[ac], XtNcolormap, cmap); ac++; } if (!NILP (parent)) @@ -1995,7 +1992,7 @@ though, the failure to call the popup callbacks resulted in XEmacs not accepting any input. Bizarre but true. Stupid but true. - So, in case there are any other gotches floating out there along + So, in case there are any other gotchas floating out there along the same lines I've duplicated the majority of XtPopup here. It assumes no grabs and that the widget is not already popped up, both valid assumptions for the one place this is called from. */ @@ -2021,12 +2018,6 @@ Xt_SET_VALUE (widget, XtNmappedWhenManaged, True); } -#ifdef HAVE_CDE -/* Does this have to be non-automatic? */ -/* hack frame to respond to dnd messages */ -static XtCallbackRec dnd_transfer_cb_rec[2]; -#endif /* HAVE_CDE */ - /* create the windows for the specified frame and display them. Note that the widgets have already been created, and any necessary geometry calculations have already been done. */ @@ -2081,7 +2072,7 @@ #ifdef HACK_EDITRES /* Allow XEmacs to respond to EditRes requests. See the O'Reilly Xt */ - /* Instrinsics Programming Manual, Motif Edition, Aug 1993, Sect 14.14, */ + /* Intrinsics Programming Manual, Motif Edition, Aug 1993, Sect 14.14, */ /* pp. 483-493. */ XtAddEventHandler (shell_widget, /* the shell widget in question */ (EventMask) NoEventMask,/* OR with existing mask */ @@ -2092,6 +2083,8 @@ #ifdef HAVE_CDE { + XtCallbackRec dnd_transfer_cb_rec[2]; + dnd_transfer_cb_rec[0].callback = x_cde_transfer_callback; dnd_transfer_cb_rec[0].closure = (XtPointer) f; dnd_transfer_cb_rec[1].callback = NULL; @@ -2101,7 +2094,7 @@ DtDND_FILENAME_TRANSFER | DtDND_BUFFER_TRANSFER, XmDROP_COPY, dnd_transfer_cb_rec, DtNtextIsBuffer, True, - DtNregisterChildren, True, + DtNregisterChildren, True, DtNpreserveRegistration, False, NULL); } @@ -2183,9 +2176,9 @@ * will update the frame title anyway, so nothing is lost. * JV: * It turns out it gives problems with FVWMs name based mapping. - * We'll just need to be carefull in the modeline specs. + * We'll just need to be careful in the modeline specs. */ - update_frame_title (f); + update_frame_title (f); } static void @@ -2199,8 +2192,8 @@ static void x_mark_frame (struct frame *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FRAME_X_ICON_PIXMAP (f))); - ((markobj) (FRAME_X_ICON_PIXMAP_MASK (f))); + markobj (FRAME_X_ICON_PIXMAP (f)); + markobj (FRAME_X_ICON_PIXMAP_MASK (f)); } static void @@ -2630,40 +2623,54 @@ static void x_delete_frame (struct frame *f) { - Widget w = FRAME_X_SHELL_WIDGET (f); - Display *dpy = XtDisplay (w); - #ifndef HAVE_SESSION if (FRAME_X_TOP_LEVEL_FRAME_P (f)) x_wm_maybe_move_wm_command (f); #endif /* HAVE_SESSION */ -#ifdef EXTERNAL_WIDGET - expect_x_error (dpy); - /* for obscure reasons having (I think) to do with the internal - window-to-widget hierarchy maintained by Xt, we have to call - XtUnrealizeWidget() here. Xt can really suck. */ - if (f->being_deleted) - XtUnrealizeWidget (w); - XtDestroyWidget (w); - x_error_occurred_p (dpy); -#else - XtDestroyWidget (w); - XFlush (dpy); /* make sure the windows are really gone! */ -#endif /* EXTERNAL_WIDGET */ +#ifdef HAVE_CDE + DtDndDropUnregister (FRAME_X_TEXT_WIDGET (f)); +#endif /* HAVE_CDE */ + + assert (FRAME_X_SHELL_WIDGET (f)); + if (FRAME_X_SHELL_WIDGET (f)) + { + Display *dpy = XtDisplay (FRAME_X_SHELL_WIDGET (f)); + expect_x_error (dpy); + /* for obscure reasons having (I think) to do with the internal + window-to-widget hierarchy maintained by Xt, we have to call + XtUnrealizeWidget() here. Xt can really suck. */ + if (f->being_deleted) + XtUnrealizeWidget (FRAME_X_SHELL_WIDGET (f)); + XtDestroyWidget (FRAME_X_SHELL_WIDGET (f)); + x_error_occurred_p (dpy); + + /* make sure the windows are really gone! */ + /* ### Is this REALLY necessary? */ + XFlush (dpy); + + FRAME_X_SHELL_WIDGET (f) = 0; + } if (FRAME_X_GEOM_FREE_ME_PLEASE (f)) - xfree (FRAME_X_GEOM_FREE_ME_PLEASE (f)); - xfree (f->frame_data); - f->frame_data = 0; + { + xfree (FRAME_X_GEOM_FREE_ME_PLEASE (f)); + FRAME_X_GEOM_FREE_ME_PLEASE (f) = 0; + } + + if (f->frame_data) + { + xfree (f->frame_data); + f->frame_data = 0; + } } static void x_update_frame_external_traits (struct frame* frm, Lisp_Object name) { - Arg av[10]; + Arg al[10]; int ac = 0; - Lisp_Object frame = Qnil; + Lisp_Object frame; XSETFRAME(frame, frm); @@ -2675,7 +2682,7 @@ if (!EQ (color, Vthe_null_color_instance)) { fgc = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (color)); - XtSetArg (av[ac], XtNforeground, (void *) fgc.pixel); ac++; + XtSetArg (al[ac], XtNforeground, (void *) fgc.pixel); ac++; } } else if (EQ (name, Qbackground)) @@ -2686,7 +2693,7 @@ if (!EQ (color, Vthe_null_color_instance)) { bgc = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (color)); - XtSetArg (av[ac], XtNbackground, (void *) bgc.pixel); ac++; + XtSetArg (al[ac], XtNbackground, (void *) bgc.pixel); ac++; } /* Really crappy way to force the modeline shadows to be @@ -2699,14 +2706,14 @@ Lisp_Object font = FACE_FONT (Vdefault_face, frame, Vcharset_ascii); if (!EQ (font, Vthe_null_font_instance)) - XtSetArg (av[ac], XtNfont, + XtSetArg (al[ac], XtNfont, (void *) FONT_INSTANCE_X_FONT (XFONT_INSTANCE (font))); ac++; } else abort (); - XtSetValues (FRAME_X_TEXT_WIDGET (frm), av, ac); + XtSetValues (FRAME_X_TEXT_WIDGET (frm), al, ac); #ifdef HAVE_TOOLBARS /* Setting the background clears the entire frame area diff -r 76b7d63099ad -r 8626e4521993 src/frame.c --- a/src/frame.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/frame.c Mon Aug 13 11:07:10 2007 +0200 @@ -39,9 +39,6 @@ #include "scrollbar.h" #include "window.h" -#include -#include "sysdep.h" - Lisp_Object Vselect_frame_hook, Qselect_frame_hook; Lisp_Object Vdeselect_frame_hook, Qdeselect_frame_hook; Lisp_Object Vcreate_frame_hook, Qcreate_frame_hook; @@ -128,7 +125,7 @@ { struct frame *f = XFRAME (obj); -#define MARKED_SLOT(x) ((markobj) (f->x)); +#define MARKED_SLOT(x) ((void) (markobj (f->x))); #include "frameslots.h" if (FRAME_LIVE_P (f)) /* device is nil for a dead frame */ @@ -190,10 +187,10 @@ XWINDOW (root_window)->frame = frame; /* 10 is arbitrary, - just so that there is "something there." + Just so that there is "something there." Correct size will be set up later with change_frame_size. */ - f->width = 10; + f->width = 10; f->height = 10; XWINDOW (root_window)->pixel_width = 10; @@ -580,7 +577,7 @@ void invalidate_vertical_divider_cache_in_frame (struct frame *f) { - /* Invalidate cached value of needs_vertical_divider_p in + /* Invalidate cached value of needs_vertical_divider_p in every and all windows */ map_windows (f, invalidate_vertical_divider_cache_in_window, 0); } @@ -892,7 +889,7 @@ #ifdef HAVE_TOOLBARS if (!EQ (f->last_nonminibuf_window, window)) MARK_TOOLBAR_CHANGED; -#endif +#endif f->last_nonminibuf_window = window; } } @@ -2795,7 +2792,7 @@ /* when frame_conversion_internal() calculated the number of rows/cols in the frame, the theoretical toolbar sizes were subtracted out. - The caluclations below adjust for real toolbar height/width in + The calculations below adjust for real toolbar height/width in frame, which may be different from frame spec, taking the above fact into account */ new_pixheight += @@ -2803,7 +2800,7 @@ + 2 * FRAME_THEORETICAL_TOP_TOOLBAR_BORDER_WIDTH (f) - FRAME_REAL_TOP_TOOLBAR_HEIGHT (f) - 2 * FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f); - + new_pixheight += + FRAME_THEORETICAL_BOTTOM_TOOLBAR_HEIGHT (f) + 2 * FRAME_THEORETICAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f) @@ -2815,13 +2812,13 @@ + 2 * FRAME_THEORETICAL_LEFT_TOOLBAR_BORDER_WIDTH (f) - FRAME_REAL_LEFT_TOOLBAR_WIDTH (f) - 2 * FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH (f); - + new_pixwidth += + FRAME_THEORETICAL_RIGHT_TOOLBAR_WIDTH (f) + 2 * FRAME_THEORETICAL_RIGHT_TOOLBAR_BORDER_WIDTH (f) - FRAME_REAL_RIGHT_TOOLBAR_WIDTH (f) - 2 * FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH (f); - + /* Adjust the width for the end glyph which may be a different width than the default character width. */ { @@ -2907,7 +2904,7 @@ FRAME_CHARWIDTH (f) = FRAME_WIDTH (f); FRAME_CHARHEIGHT (f) = FRAME_HEIGHT (f); } - + MARK_FRAME_TOOLBARS_CHANGED (f); MARK_FRAME_CHANGED (f); f->echo_area_garbaged = 1; diff -r 76b7d63099ad -r 8626e4521993 src/frame.h --- a/src/frame.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/frame.h Mon Aug 13 11:07:10 2007 +0200 @@ -23,8 +23,14 @@ #ifndef _XEMACS_FRAME_H_ #define _XEMACS_FRAME_H_ +#ifdef HAVE_SCROLLBARS #include "scrollbar.h" +#endif + +#ifdef HAVE_TOOLBARS #include "toolbar.h" +#endif + #include "device.h" #define FRAME_TYPE_NAME(f) ((f)->framemeths->name) @@ -48,7 +54,7 @@ struct console_methods *framemeths; /* Size of text only area of this frame, excluding scrollbars, - toolbars and end of line glyphs. The size can be in charactes + toolbars and end of line glyphs. The size can be in characters or pixels, depending on units in which window system resizes its windows */ int height, width; @@ -60,7 +66,7 @@ /* Size of text-only are of the frame, in default font characters. This may be inaccurate due to rounding error */ int char_height, char_width; - + /* Size of the whole frame, including scrollbars, toolbars and end of line glyphs, in pixels */ int pixheight, pixwidth; @@ -108,7 +114,7 @@ #include "frameslots.h" /* Nonzero if frame is currently displayed. - Mutally exclusive with iconfied + Mutually exclusive with iconified JV: This now a tristate flag: Value : Emacs meaning :f-v-p : X meaning 0 : not displayed : nil : unmapped diff -r 76b7d63099ad -r 8626e4521993 src/free-hook.c --- a/src/free-hook.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/free-hook.c Mon Aug 13 11:07:10 2007 +0200 @@ -62,15 +62,7 @@ there will be a large amount, so this might not be very useful. */ -#if defined (EMACS_BTL) && defined (sun4) && !defined (__lucid) -/* currently only works in this configuration */ -# define SAVE_STACK -#endif - #ifdef emacs -#ifdef SAVE_STACK -#include "cadillac-btl.h" -#endif #include #include "lisp.h" #else @@ -93,7 +85,7 @@ /* System function prototypes don't belong in C source files */ /* extern void free (void *); */ -c_hashtable pointer_table; +struct hash_table *pointer_table; extern void (*__free_hook) (void *); extern void *(*__malloc_hook) (unsigned long); @@ -102,12 +94,8 @@ typedef void (*fun_ptr) (); -#ifdef SAVE_STACK -#define FREE_QUEUE_LIMIT 1000 -#else /* free_queue is not too useful without backtrace logging */ #define FREE_QUEUE_LIMIT 1 -#endif #define TRACE_LIMIT 20 typedef struct { @@ -120,98 +108,21 @@ typedef struct { void *address; unsigned long length; -#ifdef SAVE_STACK - fun_entry backtrace[TRACE_LIMIT]; -#endif } free_queue_entry; free_queue_entry free_queue[FREE_QUEUE_LIMIT]; int current_free; -#ifdef SAVE_STACK -static void -init_frame (FRAME *fptr) -{ - FRAME tmp_frame; - -#ifdef sparc - /* Do the system trap ST_FLUSH_WINDOWS */ - asm ("ta 3"); - asm ("st %sp, [%i0+0]"); - asm ("st %fp, [%i0+4]"); -#endif - - fptr->pc = (char *) init_frame; - tmp_frame = *fptr; - - PREVIOUS_FRAME (tmp_frame); - - *fptr = tmp_frame; - return; -} - -#ifdef SAVE_ARGS -static void * -frame_arg (FRAME *fptr, int index) -{ - return ((void *) FRAME_ARG(*fptr, index)); -} -#endif - -static void -save_backtrace (FRAME *current_frame_ptr, fun_entry *table) -{ - int i = 0; -#ifdef SAVE_ARGS - int j; -#endif - FRAME current_frame = *current_frame_ptr; - - /* Get up and out of free() */ - PREVIOUS_FRAME (current_frame); - - /* now do the basic loop adding data until there is no more */ - while (PREVIOUS_FRAME (current_frame) && i < TRACE_LIMIT) - { - table[i].return_pc = (void (*)())FRAME_PC (current_frame); -#ifdef SAVE_ARGS - for (j = 0; j < 3; j++) - table[i].arg[j] = frame_arg (¤t_frame, j); -#endif - i++; - } - memset (&table[i], 0, sizeof (fun_entry) * (TRACE_LIMIT - i)); -} - -free_queue_entry * -find_backtrace (void *ptr) -{ - int i; - - for (i = 0; i < FREE_QUEUE_LIMIT; i++) - if (free_queue[i].address == ptr) - return &free_queue[i]; - - return 0; -} -#endif /* SAVE_STACK */ - int strict_free_check; static void check_free (void *ptr) { -#ifdef SAVE_STACK - FRAME start_frame; - - init_frame (&start_frame); -#endif - __free_hook = 0; __malloc_hook = 0; if (!pointer_table) - pointer_table = make_hashtable (max (100, FREE_QUEUE_LIMIT * 2)); + pointer_table = make_hash_table (max (100, FREE_QUEUE_LIMIT * 2)); if (ptr != 0) { long size; @@ -273,10 +184,7 @@ #endif free_queue[current_free].address = ptr; free_queue[current_free].length = size; -#ifdef SAVE_STACK - save_backtrace (&start_frame, - free_queue[current_free].backtrace); -#endif + current_free++; if (current_free >= FREE_QUEUE_LIMIT) current_free = 0; @@ -324,7 +232,7 @@ #endif result = malloc (rounded_up_size); if (!pointer_table) - pointer_table = make_hashtable (FREE_QUEUE_LIMIT * 2); + pointer_table = make_hash_table (FREE_QUEUE_LIMIT * 2); puthash (result, (void *)size, pointer_table); __free_hook = check_free; __malloc_hook = check_malloc; @@ -519,9 +427,6 @@ int line; blocktype type; int value; -#ifdef SAVE_STACK - fun_entry backtrace[TRACE_LIMIT]; -#endif }; typedef struct block_input_history_struct block_input_history; @@ -554,22 +459,11 @@ note_block (char *file, int line, blocktype type) { -#ifdef SAVE_STACK - FRAME start_frame; - - init_frame (&start_frame); -#endif - blhist[blhistptr].file = file; blhist[blhistptr].line = line; blhist[blhistptr].type = type; blhist[blhistptr].value = interrupt_input_blocked; -#ifdef SAVE_STACK - save_backtrace (&start_frame, - blhist[blhistptr].backtrace); -#endif - blhistptr++; if (blhistptr >= BLHISTLIMIT) blhistptr = 0; @@ -601,16 +495,10 @@ abort (); OK:; } -#ifdef SAVE_STACK - init_frame (&start_frame); -#endif gcprohist[gcprohistptr].file = file; gcprohist[gcprohistptr].line = line; gcprohist[gcprohistptr].type = type; gcprohist[gcprohistptr].value = (int) value; -#ifdef SAVE_STACK - save_backtrace (&start_frame, gcprohist[gcprohistptr].backtrace); -#endif gcprohistptr++; if (gcprohistptr >= GCPROHISTLIMIT) gcprohistptr = 0; diff -r 76b7d63099ad -r 8626e4521993 src/gdbinit --- a/src/gdbinit Mon Aug 13 11:06:08 2007 +0200 +++ b/src/gdbinit Mon Aug 13 11:07:10 2007 +0200 @@ -221,12 +221,12 @@ else if $type == dbg_Lisp_Type_Symbol || $imp == lrecord_symbol pstruct Lisp_Symbol - printf "Symbol name: %s\n", $xstruct->name->_data + printf "Symbol name: %s\n", $xstruct->name->data else if $type == dbg_Lisp_Type_Vector || $imp == lrecord_vector pstruct Lisp_Vector printf "Vector of length %d\n", $xstruct->size - #print *($xstruct->_data) @ $xstruct->size + #print *($xstruct->data) @ $xstruct->size else if $imp == lrecord_bit_vector pstruct Lisp_Bit_Vector @@ -259,7 +259,7 @@ pstruct console else if $imp == lrecord_database - pstruct database + pstruct Lisp_Database else if $imp == lrecord_device pstruct device @@ -291,14 +291,14 @@ if $imp == lrecord_glyph pstruct Lisp_Glyph else - if $imp == lrecord_hashtable - pstruct hashtable + if $imp == lrecord_hash_table + pstruct Lisp_Hash_Table else if $imp == lrecord_image_instance pstruct Lisp_Image_Instance else if $imp == lrecord_keymap - pstruct keymap + pstruct Lisp_Keymap else if $imp == lrecord_lcrecord_list pstruct lcrecord_list @@ -378,6 +378,7 @@ end end end + # Repeat after me... gdb sux, gdb sux, gdb sux... end end end @@ -396,6 +397,7 @@ end end end + # Are we having fun yet?? end end end diff -r 76b7d63099ad -r 8626e4521993 src/getloadavg.c --- a/src/getloadavg.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/getloadavg.c Mon Aug 13 11:07:10 2007 +0200 @@ -58,7 +58,7 @@ __linux__ Linux: assumes /proc filesystem mounted. Support from Michael K. Johnson. __NetBSD__ NetBSD: assumes /kern filesystem mounted. - __OpenBSD__ OpenBSD: dito. + __OpenBSD__ OpenBSD: ditto. In addition, to avoid nesting many #ifdefs, we internally set LDAV_DONE to indicate that the load average has been computed. @@ -563,7 +563,8 @@ } for (elem = 0; elem < nelem; elem++) { - kstat_named_t *kn = kstat_data_lookup (ksp, avestrings[elem]); + kstat_named_t *kn = + (kstat_named_t *) kstat_data_lookup (ksp, avestrings[elem]); if (!kn) { kstat_close (kc); diff -r 76b7d63099ad -r 8626e4521993 src/gifrlib.h --- a/src/gifrlib.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/gifrlib.h Mon Aug 13 11:07:10 2007 +0200 @@ -36,11 +36,7 @@ typedef unsigned char * GifRowType; typedef unsigned char GifByteType; -#ifdef SYSV -#define VoidPtr char * -#else #define VoidPtr void * -#endif /* SYSV */ typedef struct GifColorType { GifByteType Red, Green, Blue; @@ -167,7 +163,7 @@ /* This is the in-core version of an extension record */ typedef struct { - int ByteCount; + int ByteCount; GifByteType *Bytes; /* on malloc(3) heap */ } ExtensionBlock; diff -r 76b7d63099ad -r 8626e4521993 src/glyphs-eimage.c --- a/src/glyphs-eimage.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/glyphs-eimage.c Mon Aug 13 11:07:10 2007 +0200 @@ -55,10 +55,8 @@ #include "buffer.h" #include "frame.h" -#include "insdel.h" #include "opaque.h" -#include "imgproc.h" #include "sysfile.h" #ifdef HAVE_PNG @@ -76,16 +74,6 @@ #include "file-coding.h" #endif -#if INTBITS == 32 -# define FOUR_BYTE_TYPE unsigned int -#elif LONGBITS == 32 -# define FOUR_BYTE_TYPE unsigned long -#elif SHORTBITS == 32 -# define FOUR_BYTE_TYPE unsigned short -#else -#error What kind of strange-ass system are we running on? -#endif - #ifdef HAVE_TIFF DEFINE_IMAGE_INSTANTIATOR_FORMAT (tiff); Lisp_Object Qtiff; @@ -419,7 +407,7 @@ { /* we're relying on the jpeg driver to do any other conversions, or signal an error if the conversion isn't supported. */ - cinfo.out_color_space = JCS_RGB; + cinfo.out_color_space = JCS_RGB; } /* Step 5: Start decompressor */ @@ -465,7 +453,7 @@ for (i = 0; i < cinfo.output_width; i++) { int clr; - if (jpeg_gray) + if (jpeg_gray) { unsigned char val; #if (BITS_IN_JSAMPLE == 8) @@ -492,10 +480,10 @@ /* Step 6.5: Create the pixmap and set up the image instance */ /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, cinfo.output_width, cinfo.output_height, - unwind.eimage, dest_mask, + (ii, cinfo.output_width, cinfo.output_height, + unwind.eimage, dest_mask, instantiator, domain)); /* Step 7: Finish decompression */ @@ -576,9 +564,9 @@ gif_read_from_memory(GifByteType *buf, size_t size, VoidPtr data) { gif_memory_storage *mem = (gif_memory_storage*)data; - + if (size > (mem->len - mem->index)) - return -1; + return (size_t) -1; memcpy(buf, mem->bytes + mem->index, size); mem->index = mem->index + size; return size; @@ -623,20 +611,20 @@ Extcount len; int height = 0; int width = 0; - + xzero (unwind); record_unwind_protect (gif_instantiate_unwind, make_opaque_ptr (&unwind)); - + /* 1. Now decode the data. */ - + { Lisp_Object data = find_keyword_in_vector (instantiator, Q_data); - + assert (!NILP (data)); - + if (!(unwind.giffile = GifSetup())) signal_image_error ("Insufficent memory to instantiate GIF image", instantiator); - + /* set up error facilities */ if (setjmp(gif_err.setjmp_buffer)) { @@ -647,7 +635,7 @@ signal_image_error_2 ("GIF decoding error", errstring, instantiator); } GifSetErrorFunc(unwind.giffile, (Gif_error_func)gif_error_func, (VoidPtr)&gif_err); - + GET_STRING_BINARY_DATA_ALLOCA (data, bytes, len); mem_struct.bytes = bytes; mem_struct.len = len; @@ -655,14 +643,14 @@ GifSetReadFunc(unwind.giffile, gif_read_from_memory, (VoidPtr)&mem_struct); GifSetCloseFunc(unwind.giffile, gif_memory_close, (VoidPtr)&mem_struct); DGifInitRead(unwind.giffile); - + /* Then slurp the image into memory, decoding along the way. The result is the image in a simple one-byte-per-pixel format (#### the GIF routines only support 8-bit GIFs, it appears). */ DGifSlurp (unwind.giffile); } - + /* 3. Now create the EImage */ { ColorMapObject *cmo = unwind.giffile->SColorMap; @@ -672,15 +660,15 @@ 0, 8, 16, ..., 4, 12, 20, ..., 2, 6, 10, ..., 1, 3, 5, ... */ static int InterlacedOffset[] = { 0, 4, 2, 1 }; static int InterlacedJumps[] = { 8, 8, 4, 2 }; - + height = unwind.giffile->SHeight; width = unwind.giffile->SWidth; unwind.eimage = (unsigned char*) xmalloc (width * height * 3); if (!unwind.eimage) signal_image_error("Unable to allocate enough memory for image", instantiator); - + /* write the data in EImage format (8bit RGB triples) */ - + /* Note: We just use the first image in the file and ignore the rest. We check here that that image covers the full "screen" size. I don't know whether that's always the case. @@ -691,7 +679,7 @@ || unwind.giffile->SavedImages[0].ImageDesc.Top != 0) signal_image_error ("First image in GIF file is not full size", instantiator); - + interlace = unwind.giffile->SavedImages[0].ImageDesc.Interlace; pass = 0; row = interlace ? InterlacedOffset[pass] : 0; @@ -701,7 +689,7 @@ if (interlace) if (row >= height) { row = InterlacedOffset[++pass]; - while (row > height) + while (row > height) row = InterlacedOffset[++pass]; } eip = unwind.eimage + (row * width * 3); @@ -716,11 +704,11 @@ } } /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, width, height, unwind.eimage, dest_mask, + (ii, width, height, unwind.eimage, dest_mask, instantiator, domain)); - + unbind_to (speccount, Qnil); } @@ -778,7 +766,7 @@ /* jh 98/03/12 - #### AARRRGH! libpng includes jmp_buf inside its own structure, and there are cases where the size can be different from - between inside the libarary, and inside the code! To do an end run + between inside the library, and inside the code! To do an end run around this, use our own error functions, and don't rely on things passed in the png_ptr to them. This is an ugly hack and must go away when the lisp engine is threaded! */ @@ -848,7 +836,7 @@ png_destroy_read_struct (&png_ptr, (png_infopp)NULL, (png_infopp)NULL); signal_image_error ("Error obtaining memory for png_read", instantiator); } - + xzero (unwind); unwind.png_ptr = png_ptr; unwind.info_ptr = info_ptr; @@ -863,7 +851,7 @@ and is no longer usable for previous versions. jh */ - /* Set the jmp_buf reurn context for png_error ... if this returns !0, then + /* Set the jmp_buf return context for png_error ... if this returns !0, then we ran into a problem somewhere, and need to clean up after ourselves. */ if (setjmp (png_err_stct.setjmp_buffer)) { @@ -903,7 +891,7 @@ /* libpng expects that the image buffer passed in contains a picture to draw on top of if the png has any transparencies. This could be a good place to pass that in... */ - + row_pointers = xnew_array (png_byte *, height); for (y = 0; y < height; y++) @@ -936,18 +924,18 @@ my_background.green = XINT (XCAR (XCDR (rgblist))); my_background.blue = XINT (XCAR (XCDR (XCDR (rgblist)))); } - + if (png_get_bKGD (png_ptr, info_ptr, &image_background)) png_set_background (png_ptr, image_background, PNG_BACKGROUND_GAMMA_FILE, 1, 1.0); - else + else png_set_background (png_ptr, &my_background, PNG_BACKGROUND_GAMMA_SCREEN, 0, 1.0); } /* Now that we're using EImage, ask for 8bit RGB triples for any type of image*/ - /* convert palatte images to full RGB */ + /* convert palette images to full RGB */ if (info_ptr->color_type == PNG_COLOR_TYPE_PALETTE) png_set_expand (png_ptr); /* send grayscale images to RGB too */ @@ -971,7 +959,7 @@ png_read_image (png_ptr, row_pointers); png_read_end (png_ptr, info_ptr); - + #ifdef PNG_SHOW_COMMENTS /* #### * I turn this off by default now, because the !%^@#!% comments @@ -1000,9 +988,9 @@ } /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, width, height, unwind.eimage, dest_mask, + (ii, width, height, unwind.eimage, dest_mask, instantiator, domain)); /* This will clean up everything else. */ @@ -1106,7 +1094,7 @@ if ((newidx > mem->len) || (newidx < 0)) return -1; - + mem->index = newidx; return newidx; } @@ -1206,7 +1194,7 @@ xzero (unwind); record_unwind_protect (tiff_instantiate_unwind, make_opaque_ptr (&unwind)); - + /* set up error facilities */ if (setjmp (tiff_err_data.setjmp_buffer)) { @@ -1248,7 +1236,7 @@ unwind.eimage = (unsigned char *) xmalloc (width * height * 3); /* ### This is little more than proof-of-concept/function testing. - It needs to be reimplimented via scanline reads for both memory + It needs to be reimplemented via scanline reads for both memory compactness. */ raster = (uint32*) _TIFFmalloc (width * height * sizeof (uint32)); if (raster != NULL) @@ -1280,9 +1268,9 @@ } /* now instantiate */ - MAYBE_DEVMETH (XDEVICE (ii->device), + MAYBE_DEVMETH (XDEVICE (ii->device), init_image_instance_from_eimage, - (ii, width, height, unwind.eimage, dest_mask, + (ii, width, height, unwind.eimage, dest_mask, instantiator, domain)); unbind_to (speccount, Qnil); diff -r 76b7d63099ad -r 8626e4521993 src/glyphs-msw.c --- a/src/glyphs-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/glyphs-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -87,9 +87,9 @@ if (DEVICE_MSWINDOWS_BITSPIXEL (d) > 0) { int bpline = BPLINE(width * 3); - /* FIXME: we can do this because 24bpp implies no colour table, once - * we start paletizing this is no longer true. The X versions of - * this function quantises to 256 colours or bit masks down to a + /* FIXME: we can do this because 24bpp implies no color table, once + * we start palettizing this is no longer true. The X versions of + * this function quantises to 256 colors or bit masks down to a * long. Windows can actually handle rgb triples in the raw so I * don't see much point trying to optimize down to the best * structure - unless it has memory / color allocation implications @@ -699,7 +699,7 @@ break; case XpmFileInvalid: { - signal_simple_error ("invalid XPM data", image); + signal_simple_error ("Invalid XPM data", image); } case XpmNoMemory: { @@ -1173,7 +1173,7 @@ } else if (!(resid = MAKEINTRESOURCE (resource_name_to_resource (resource_id, type)))) - signal_simple_error ("invalid resource identifier", resource_id); + signal_simple_error ("Invalid resource identifier", resource_id); /* load the image */ if (!(himage = LoadImage (hinst, resid, type, 0, 0, @@ -1181,7 +1181,7 @@ LR_SHARED | (!NILP (file) ? LR_LOADFROMFILE : 0)))) { - signal_simple_error ("cannot load image", instantiator); + signal_simple_error ("Cannot load image", instantiator); } if (hinst) @@ -1295,7 +1295,7 @@ /* - * Based on an optimized version provided by Jim Becker, Auguest 5, 1988. + * Based on an optimized version provided by Jim Becker, August 5, 1988. */ #ifndef BitmapSuccess #define BitmapSuccess 0 diff -r 76b7d63099ad -r 8626e4521993 src/glyphs-x.c --- a/src/glyphs-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/glyphs-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -122,7 +122,7 @@ int depth, bitmap_pad, byte_cnt, i, j; int rd,gr,bl,q; unsigned char *data, *ip, *dp; - quant_table *qtable; + quant_table *qtable = 0; union { FOUR_BYTE_TYPE val; char cp[4]; @@ -145,7 +145,7 @@ (depth > 8) ? 16 : 8); byte_cnt = bitmap_pad >> 3; - + outimg = XCreateImage (dpy, vis, depth, ZPixmap, 0, 0, width, height, bitmap_pad, 0); @@ -158,7 +158,7 @@ return NULL; } outimg->data = (char *) data; - + if (vis->class == PseudoColor) { unsigned long pixarray[256]; @@ -174,7 +174,7 @@ { XColor color; int res; - + color.red = qtable->rm[i] ? qtable->rm[i] << 8 : 0; color.green = qtable->gm[i] ? qtable->gm[i] << 8 : 0; color.blue = qtable->bm[i] ? qtable->bm[i] << 8 : 0; @@ -287,7 +287,7 @@ #endif } } - } + } return outimg; } @@ -469,7 +469,7 @@ } if (NILP (Vdefault_x_device)) - /* This may occur during intialization. */ + /* This may occur during initialization. */ return Qnil; else /* We only check the bitmapFilePath resource on the original X device. */ @@ -609,7 +609,7 @@ /* reset the dynarr */ Lstream_rewind(ostr); } - + if (fclose (tmpfil) != 0) fubar = 1; Lstream_close (istr); @@ -791,7 +791,7 @@ static void x_init_image_instance_from_eimage (struct Lisp_Image_Instance *ii, int width, int height, - unsigned char *eimage, + unsigned char *eimage, int dest_mask, Lisp_Object instantiator, Lisp_Object domain) @@ -801,7 +801,7 @@ unsigned long *pixtbl = NULL; int npixels = 0; XImage* ximage; - + ximage = convert_EImage_to_XImage (device, width, height, eimage, &pixtbl, &npixels); if (!ximage) @@ -809,7 +809,7 @@ if (pixtbl) xfree (pixtbl); signal_image_error("EImage to XImage conversion failed", instantiator); } - + /* Now create the pixmap and set up the image instance */ init_image_instance_from_x_image (ii, ximage, dest_mask, cmap, pixtbl, npixels, @@ -826,11 +826,11 @@ } } -int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, +int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, unsigned int *height, unsigned char **datap, int *x_hot, int *y_hot) { - return XmuReadBitmapDataFromFile (filename, width, height, + return XmuReadBitmapDataFromFile (filename, width, height, datap, x_hot, y_hot); } @@ -1493,7 +1493,7 @@ static Lisp_Object xface_normalize (Lisp_Object inst, Lisp_Object console_type) { - /* This funcation can call lisp */ + /* This function can call lisp */ Lisp_Object file = Qnil, mask_file = Qnil; struct gcpro gcpro1, gcpro2, gcpro3; Lisp_Object alist = Qnil; @@ -2085,9 +2085,9 @@ /* subwindows are equal iff they have the same window XID */ static int -subwindow_equal (Lisp_Object o1, Lisp_Object o2, int depth) +subwindow_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - return (XSUBWINDOW (o1)->subwindow == XSUBWINDOW (o2)->subwindow); + return (XSUBWINDOW (obj1)->subwindow == XSUBWINDOW (obj2)->subwindow); } static unsigned long diff -r 76b7d63099ad -r 8626e4521993 src/glyphs.c --- a/src/glyphs.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/glyphs.c Mon Aug 13 11:07:10 2007 +0200 @@ -526,20 +526,20 @@ { struct Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj); - (markobj) (i->name); + markobj (i->name); switch (IMAGE_INSTANCE_TYPE (i)) { case IMAGE_TEXT: - (markobj) (IMAGE_INSTANCE_TEXT_STRING (i)); + markobj (IMAGE_INSTANCE_TEXT_STRING (i)); break; case IMAGE_MONO_PIXMAP: case IMAGE_COLOR_PIXMAP: - (markobj) (IMAGE_INSTANCE_PIXMAP_FILENAME (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_FG (i)); - (markobj) (IMAGE_INSTANCE_PIXMAP_BG (i)); + markobj (IMAGE_INSTANCE_PIXMAP_FILENAME (i)); + markobj (IMAGE_INSTANCE_PIXMAP_MASK_FILENAME (i)); + markobj (IMAGE_INSTANCE_PIXMAP_HOTSPOT_X (i)); + markobj (IMAGE_INSTANCE_PIXMAP_HOTSPOT_Y (i)); + markobj (IMAGE_INSTANCE_PIXMAP_FG (i)); + markobj (IMAGE_INSTANCE_PIXMAP_BG (i)); break; case IMAGE_SUBWINDOW: /* #### implement me */ @@ -673,10 +673,10 @@ } static int -image_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth) +image_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (o1); - struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (o2); + struct Lisp_Image_Instance *i1 = XIMAGE_INSTANCE (obj1); + struct Lisp_Image_Instance *i2 = XIMAGE_INSTANCE (obj2); struct device *d1 = XDEVICE (i1->device); struct device *d2 = XDEVICE (i2->device); @@ -958,14 +958,14 @@ /* instantiate_image_instantiator() will abort if given an image instance ... */ if (IMAGE_INSTANCEP (data)) - signal_simple_error ("image instances not allowed here", data); + signal_simple_error ("Image instances not allowed here", data); image_validate (data); dest_mask = decode_image_instance_type_list (dest_types); data = normalize_image_instantiator (data, DEVICE_TYPE (XDEVICE (device)), make_int (dest_mask)); GCPRO1 (data); if (VECTORP (data) && EQ (XVECTOR_DATA (data)[0], Qinherit)) - signal_simple_error ("inheritance not allowed here", data); + signal_simple_error ("Inheritance not allowed here", data); ii = instantiate_image_instantiator (device, device, data, Qnil, Qnil, dest_mask); RETURN_UNGCPRO (ii); @@ -1483,7 +1483,7 @@ if (!NILP (file) && NILP (data)) { Lisp_Object retval = MAYBE_LISP_CONTYPE_METH - (decode_console_type(console_type, ERROR_ME), + (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (file)); if (!NILP (retval)) @@ -1491,7 +1491,7 @@ else return Fcons (file, Qnil); /* should have been file */ } - + return Qnil; } @@ -1514,7 +1514,7 @@ Note that if we cannot generate any regular inline data, we skip out. */ - file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, + file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, console_type); if (CONSP (file)) /* failure locating filename */ @@ -1600,7 +1600,9 @@ -- maybe return an error, or return Qnil. */ -#ifndef HAVE_X_WINDOWS +#ifdef HAVE_X_WINDOWS +#include +#else #define XFree(data) free(data) #endif @@ -1614,7 +1616,7 @@ CONST char *filename_ext; GET_C_STRING_FILENAME_DATA_ALLOCA (name, filename_ext); - result = read_bitmap_data_from_file (filename_ext, &w, &h, + result = read_bitmap_data_from_file (filename_ext, &w, &h, &data, xhot, yhot); if (result == BitmapSuccess) @@ -1675,11 +1677,11 @@ && !NILP (file)) { mask_file = MAYBE_LISP_CONTYPE_METH - (decode_console_type(console_type, ERROR_ME), + (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (concat2 (file, build_string ("Mask")))); if (NILP (mask_file)) mask_file = MAYBE_LISP_CONTYPE_METH - (decode_console_type(console_type, ERROR_ME), + (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (concat2 (file, build_string ("msk")))); } @@ -1774,9 +1776,9 @@ { Lisp_Object device= IMAGE_INSTANCE_DEVICE (XIMAGE_INSTANCE (image_instance)); - MAYBE_DEVMETH (XDEVICE (device), + MAYBE_DEVMETH (XDEVICE (device), xbm_instantiate, - (image_instance, instantiator, pointer_fg, + (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain)); } @@ -1943,7 +1945,7 @@ Note that if we cannot generate any regular inline data, we skip out. */ - file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, + file = potential_pixmap_file_instantiator (inst, Q_file, Q_data, console_type); if (CONSP (file)) /* failure locating filename */ @@ -1957,7 +1959,7 @@ if (NILP (file) && !UNBOUNDP (color_symbols)) /* no conversion necessary */ RETURN_UNGCPRO (inst); - + alist = tagged_vector_to_alist (inst); if (!NILP (file)) @@ -1968,7 +1970,7 @@ alist = Fcons (Fcons (Q_file, file), Fcons (Fcons (Q_data, data), alist)); } - + if (UNBOUNDP (color_symbols)) { color_symbols = evaluate_xpm_color_symbols (); @@ -1999,9 +2001,9 @@ { Lisp_Object device= IMAGE_INSTANCE_DEVICE (XIMAGE_INSTANCE (image_instance)); - MAYBE_DEVMETH (XDEVICE (device), + MAYBE_DEVMETH (XDEVICE (device), xpm_instantiate, - (image_instance, instantiator, pointer_fg, + (image_instance, instantiator, pointer_fg, pointer_bg, dest_mask, domain)); } @@ -2029,8 +2031,8 @@ { struct Lisp_Specifier *image = XIMAGE_SPECIFIER (obj); - ((markobj) (IMAGE_SPECIFIER_ATTACHEE (image))); - ((markobj) (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image))); + markobj (IMAGE_SPECIFIER_ATTACHEE (image)); + markobj (IMAGE_SPECIFIER_ATTACHEE_PROPERTY (image)); } static Lisp_Object @@ -2121,11 +2123,11 @@ pointer face. */ - subtable = make_lisp_hashtable (20, - pointerp ? HASHTABLE_KEY_CAR_WEAK - : HASHTABLE_KEY_WEAK, - pointerp ? HASHTABLE_EQUAL - : HASHTABLE_EQ); + subtable = make_lisp_hash_table (20, + pointerp ? HASH_TABLE_KEY_CAR_WEAK + : HASH_TABLE_KEY_WEAK, + pointerp ? HASH_TABLE_EQUAL + : HASH_TABLE_EQ); Fputhash (make_int (dest_mask), subtable, d->image_instance_cache); instance = Qunbound; @@ -2484,10 +2486,10 @@ { struct Lisp_Glyph *glyph = XGLYPH (obj); - ((markobj) (glyph->image)); - ((markobj) (glyph->contrib_p)); - ((markobj) (glyph->baseline)); - ((markobj) (glyph->face)); + markobj (glyph->image); + markobj (glyph->contrib_p); + markobj (glyph->baseline); + markobj (glyph->face); return glyph->plist; } @@ -2516,10 +2518,10 @@ This isn't concerned with "unspecified" attributes, that's what #'glyph-differs-from-default-p is for. */ static int -glyph_equal (Lisp_Object o1, Lisp_Object o2, int depth) +glyph_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Glyph *g1 = XGLYPH (o1); - struct Lisp_Glyph *g2 = XGLYPH (o2); + struct Lisp_Glyph *g1 = XGLYPH (obj1); + struct Lisp_Glyph *g2 = XGLYPH (obj2); depth++; @@ -2761,12 +2763,10 @@ CHECK_GLYPH (glyph); switch (XGLYPH_TYPE (glyph)) { + default: abort (); case GLYPH_BUFFER: return Qbuffer; case GLYPH_POINTER: return Qpointer; case GLYPH_ICON: return Qicon; - default: - abort (); - return Qnil; /* not reached */ } } @@ -3084,7 +3084,7 @@ for (elt = 0; elt < Dynarr_length (elements); elt++) { struct glyph_cachel *cachel = Dynarr_atp (elements, elt); - ((markobj) (cachel->glyph)); + markobj (cachel->glyph); } } diff -r 76b7d63099ad -r 8626e4521993 src/glyphs.h --- a/src/glyphs.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/glyphs.h Mon Aug 13 11:07:10 2007 +0200 @@ -112,11 +112,10 @@ #define IIFORMAT_METH(mstruc, m, args) (((mstruc)->m##_method) args) /* Call a void-returning specifier method, if it exists */ -#define MAYBE_IIFORMAT_METH(mstruc, m, args) \ -do { \ - struct image_instantiator_methods *_maybe_iiformat_meth_mstruc = (mstruc); \ - if (HAS_IIFORMAT_METH_P (_maybe_iiformat_meth_mstruc, m)) \ - IIFORMAT_METH (_maybe_iiformat_meth_mstruc, m, args); \ +#define MAYBE_IIFORMAT_METH(mstruc, m, args) do { \ + struct image_instantiator_methods *maybe_iiformat_meth_mstruc = (mstruc); \ + if (HAS_IIFORMAT_METH_P (maybe_iiformat_meth_mstruc, m)) \ + IIFORMAT_METH (maybe_iiformat_meth_mstruc, m, args); \ } while (0) /* Call a specifier method, if it exists; otherwise return @@ -185,7 +184,7 @@ Lisp_Object find_keyword_in_vector_or_given (Lisp_Object vector, Lisp_Object keyword, Lisp_Object default_); -Lisp_Object simple_image_type_normalize (Lisp_Object inst, +Lisp_Object simple_image_type_normalize (Lisp_Object inst, Lisp_Object console_type, Lisp_Object image_type_tag); Lisp_Object potential_pixmap_file_instantiator (Lisp_Object instantiator, @@ -403,11 +402,11 @@ #ifdef HAVE_WINDOW_SYSTEM Lisp_Object bitmap_to_lisp_data (Lisp_Object name, int *xhot, int *yhot, int ok_if_data_invalid); -int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, +int read_bitmap_data_from_file (CONST char *filename, unsigned int *width, unsigned int *height, unsigned char **datap, int *x_hot, int *y_hot); Lisp_Object xbm_mask_file_munging (Lisp_Object alist, Lisp_Object file, - Lisp_Object mask_file, + Lisp_Object mask_file, Lisp_Object console_type); #endif diff -r 76b7d63099ad -r 8626e4521993 src/gui-x.c --- a/src/gui-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/gui-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -274,16 +274,16 @@ #if 1 /* Eval the activep slot of the menu item */ -# define wv_set_evalable_slot(slot,form) \ - do { Lisp_Object _f_ = (form); \ - slot = (NILP (_f_) ? 0 : \ - EQ (_f_, Qt) ? 1 : \ - !NILP (Feval (_f_))); \ - } while (0) +# define wv_set_evalable_slot(slot,form) do { \ + Lisp_Object wses_form = (form); \ + (slot) = (NILP (wses_form) ? 0 : \ + EQ (wses_form, Qt) ? 1 : \ + !NILP (Feval (wses_form))); \ +} while (0) #else /* Treat the activep slot of the menu item as a boolean */ # define wv_set_evalable_slot(slot,form) \ - slot = (!NILP ((form))) + ((void) (slot = (!NILP (form)))) #endif char * @@ -297,7 +297,8 @@ first = s[0]; if (first != '-' && first != '=') return NULL; - for (p = s; *p == first; p++); + for (p = s; *p == first; p++) + DO_NOTHING; /* #### - cannot currently specify a separator tag "--!tag" and a separator style "--:style" at the same time. */ @@ -361,7 +362,7 @@ int selected_spec = 0, included_spec = 0; if (length < 2) - signal_simple_error ("button descriptors must be at least 2 long", desc); + signal_simple_error ("Button descriptors must be at least 2 long", desc); /* length 2: [ "name" callback ] length 3: [ "name" callback active-p ] @@ -386,7 +387,7 @@ int i; if (length & 1) signal_simple_error ( - "button descriptor has an odd number of keywords and values", + "Button descriptor has an odd number of keywords and values", desc); name = contents [0]; @@ -396,7 +397,7 @@ Lisp_Object key = contents [i++]; Lisp_Object val = contents [i++]; if (!KEYWORDP (key)) - signal_simple_error_2 ("not a keyword", key, desc); + signal_simple_error_2 ("Not a keyword", key, desc); if (EQ (key, Q_active)) active_p = val; else if (EQ (key, Q_suffix)) suffix = val; @@ -411,12 +412,12 @@ || CHARP (val)) accel = val; else - signal_simple_error ("bad keyboard accelerator", val); + signal_simple_error ("Bad keyboard accelerator", val); } else if (EQ (key, Q_filter)) signal_simple_error(":filter keyword not permitted on leaf nodes", desc); else - signal_simple_error_2 ("unknown menu item keyword", key, desc); + signal_simple_error_2 ("Unknown menu item keyword", key, desc); } } @@ -529,10 +530,10 @@ #endif } else - signal_simple_error_2 ("unknown style", style, desc); + signal_simple_error_2 ("Unknown style", style, desc); if (!allow_text_field_p && (wv->type == TEXT_TYPE)) - signal_simple_error ("text field not allowed in this context", desc); + signal_simple_error ("Text field not allowed in this context", desc); if (selected_spec && EQ (style, Qtext)) signal_simple_error ( diff -r 76b7d63099ad -r 8626e4521993 src/gui.c --- a/src/gui.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/gui.c Mon Aug 13 11:07:10 2007 +0200 @@ -26,7 +26,7 @@ #include #include "lisp.h" #include "gui.h" -#include "bytecode.h" /* for struct Lisp_Compiled_Function */ +#include "bytecode.h" Lisp_Object Q_active, Q_suffix, Q_keys, Q_style, Q_selected; Lisp_Object Q_filter, Q_config, Q_included, Q_key_sequence; diff -r 76b7d63099ad -r 8626e4521993 src/hash.c --- a/src/hash.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/hash.c Mon Aug 13 11:07:10 2007 +0200 @@ -33,10 +33,16 @@ #endif /* !emacs */ #include "hash.h" -#include "elhash.h" + +#define COMFORTABLE_SIZE(size) (21 * (size) / 16) -static CONST unsigned int -primes []={ +/* Knuth volume 3, hash functions */ +#define WORD_HASH_4(word) (0x9c406b55 * (word)) +#define WORD_HASH_8(word) (0x9c406b549c406b55 * (word)) + +static CONST hash_size_t +primes [] = +{ 13, 29, 37, 47, 59, 71, 89, 107, 131, 163, 197, 239, 293, 353, 431, 521, 631, 761, 919, 1103, 1327, 1597, 1931, 2333, 2801, 3371, 4049, 4861, 5839, 7013, @@ -46,7 +52,147 @@ 2009191, 2411033, 2893249 }; -/* strings code */ +#if 0 +static CONST hash_size_t +primes [] = +{ + 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) +{ + unsigned int h = 0; + unsigned CONST char *x = (unsigned CONST char *) xv; + + if (!x) return 0; + + while (size--) + { + unsigned int g; + h = (h << 4) + *x++; + if ((g = h & 0xf0000000) != 0) + h = (h ^ (g >> 24)) ^ g; + } + + return h; +} + +/* We've heard of binary search. */ +static hash_size_t +prime_size (hash_size_t size) +{ + 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, struct hash_table *ht, hash_size_t size); + +#define KEYS_DIFFER_P(old, new, testfun) \ + (((old) != (new)) && (!(testfun) || !(testfun) ((old),(new)))) + +CONST void * +gethash (CONST void *key, struct hash_table *hash_table, CONST void **ret_value) +{ + 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_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_table->zero_entry; + return (void *) hash_table->zero_set; + } + + if (e_key ? + KEYS_DIFFER_P (e_key, key, test_function) : + e->contents == NULL_ENTRY) + { + size_t h2 = size - 2; + unsigned int incr = 1 + (hcode_initial % h2); + do + { + 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); + } + + *ret_value = e->contents; + return e->key; +} + +void +clrhash (struct hash_table *hash_table) +{ + 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_hash_table (struct hash_table *hash_table) +{ + xfree (hash_table->harray); + xfree (hash_table); +} + +struct hash_table* +make_hash_table (hash_size_t size) +{ + 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; +} + +struct hash_table * +make_general_hash_table (hash_size_t size, + hash_table_hash_function hash_function, + hash_table_test_function test_function) +{ + struct hash_table* hash_table = make_hash_table (size); + hash_table->hash_function = hash_function; + hash_table->test_function = test_function; + return hash_table; +} + +#if 0 /* unused strings code */ +struct hash_table * +make_strings_hash_table (hash_size_t size) +{ + return make_general_hash_table (size, string_hash, string_eq); +} /* from base/generic-hash.cc, and hence from Dragon book, p436 */ unsigned long @@ -68,320 +214,136 @@ return h; } -unsigned long -memory_hash (CONST void *xv, size_t size) +static int +string_eq (CONST void *s1, CONST void *s2) { - unsigned int h = 0; - unsigned CONST char *x = (unsigned CONST char *) xv; - - if (!x) return 0; - - while (size > 0) - { - 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) -{ - int i; - for (i = 0; i < countof (primes); i++) - if (size <= primes [i]) - return primes [i]; - return primes [countof (primes) - 1]; + return s1 && s2 ? !strcmp ((CONST char *) s1, (CONST char *) s2) : s1 == s2; } - -static void rehash (hentry *harray, c_hashtable ht, unsigned int size); - -#define KEYS_DIFFER_P(old, new, testfun) \ - ((testfun)?(((old) == (new))?0:(!(testfun ((old), new)))):((old) != (new))) - -CONST void * -gethash (CONST void *key, c_hashtable hash, CONST void **ret_value) -{ - hentry *harray = hash->harray; - int (*test_function) (CONST void *, CONST void *) = hash->test_function; - unsigned int hsize = hash->size; - unsigned int hcode_initial = - (hash->hash_function)?(hash->hash_function(key)):((unsigned long) key); - unsigned int hcode = hcode_initial % hsize; - hentry *e = &harray [hcode]; - CONST void *e_key = e->key; - - if (!key) - { - *ret_value = hash->zero_entry; - return (void *) hash->zero_set; - } - - if ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)) - { - unsigned int h2 = hsize - 2; - unsigned int incr = 1 + (hcode_initial % h2); - do - { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; - e = &harray [hcode]; - e_key = e->key; - } - while ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)); - } - - *ret_value = e->contents; - return e->key; -} +#endif /* unused strings code */ void -clrhash (c_hashtable hash) -{ - memset (hash->harray, 0, sizeof (hentry) * hash->size); - hash->zero_entry = 0; - hash->zero_set = 0; - hash->fullness = 0; -} - -void -free_hashtable (c_hashtable hash) -{ -#ifdef emacs - if (!NILP (hash->elisp_table)) - return; -#endif - xfree (hash->harray); - xfree (hash); -} - -c_hashtable -make_hashtable (unsigned int hsize) -{ - 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; -} - -c_hashtable -make_general_hashtable (unsigned int hsize, - unsigned long (*hash_function) (CONST void *), - int (*test_function) (CONST void *, CONST void *)) +copy_hash (struct hash_table *dest, struct hash_table *src) { - 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; -} - -c_hashtable -make_strings_hashtable (unsigned int hsize) -{ - return make_general_hashtable (hsize, string_hash, string_eq); -} - -#ifdef emacs -unsigned int -compute_harray_size (unsigned int hsize) -{ - return prime_size ((13 * hsize) / 10); -} -#endif - -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))) - { - error ("Incompatible hashtable types to copy_hash."); - return; - } -#endif - if (dest->size != src->size) { -#ifdef emacs - if (!NILP (dest->elisp_table)) - elisp_hvector_free (dest->harray, dest->elisp_table); - else -#endif - xfree (dest->harray); + xfree (dest->harray); dest->size = src->size; -#ifdef emacs - if (!NILP (dest->elisp_table)) - dest->harray = (hentry *) - elisp_hvector_malloc (sizeof (hentry) * dest->size, - dest->elisp_table); - else -#endif - dest->harray = xnew_array (hentry, dest->size); + dest->harray = xnew_array (hentry, dest->size); } - dest->fullness = src->fullness; - dest->zero_entry = src->zero_entry; - dest->zero_set = src->zero_set; + dest->fullness = src->fullness; + dest->zero_entry = src->zero_entry; + dest->zero_set = src->zero_set; dest->hash_function = src->hash_function; dest->test_function = src->test_function; memcpy (dest->harray, src->harray, sizeof (hentry) * dest->size); } static void -grow_hashtable (c_hashtable hash, unsigned int new_size) +grow_hash_table (struct hash_table *hash_table, hash_size_t new_size) { - unsigned int old_hsize = hash->size; - hentry *old_harray = hash->harray; - unsigned int new_hsize = prime_size (new_size); - hentry *new_harray; + hash_size_t old_size = hash_table->size; + hentry *old_harray = hash_table->harray; + hentry *new_harray; -#ifdef emacs - /* We test for Qzero to facilitate free-hook.c. That module creates - a hashtable very very early, at which point Qnil has not yet - been set and is thus all zeroes. Qzero is "automatically" - initialized at startup because its correct value is also all - zeroes. */ - if (!EQ (hash->elisp_table, Qnull_pointer) && - !NILP (hash->elisp_table) && - !ZEROP (hash->elisp_table)) - new_harray = (hentry *) elisp_hvector_malloc (sizeof (hentry) * new_hsize, - hash->elisp_table); - else -#endif - new_harray = (hentry *) xmalloc (sizeof (hentry) * new_hsize); + new_size = prime_size (new_size); - hash->size = new_hsize; - hash->harray = new_harray; + new_harray = xnew_array (hentry, new_size); + + hash_table->size = new_size; + hash_table->harray = new_harray; /* do the rehash on the "grown" table */ { - long old_zero_set = hash->zero_set; - void *old_zero_entry = hash->zero_entry; - clrhash (hash); - hash->zero_set = old_zero_set; - hash->zero_entry = old_zero_entry; - rehash (old_harray, hash, old_hsize); + long old_zero_set = hash_table->zero_set; + void *old_zero_entry = hash_table->zero_entry; + clrhash (hash_table); + hash_table->zero_set = old_zero_set; + hash_table->zero_entry = old_zero_entry; + rehash (old_harray, hash_table, old_size); } -#ifdef emacs - if (!EQ (hash->elisp_table, Qnull_pointer) && - !NILP (hash->elisp_table) && - !ZEROP (hash->elisp_table)) - elisp_hvector_free (old_harray, hash->elisp_table); - else -#endif - xfree (old_harray); + xfree (old_harray); } void -expand_hashtable (c_hashtable hash, unsigned int needed_size) +expand_hash_table (struct hash_table *hash_table, hash_size_t needed_size) { - size_t hsize = hash->size; - size_t comfortable_size = (13 * needed_size) / 10; - if (hsize < comfortable_size) - grow_hashtable (hash, comfortable_size + 1); + hash_size_t size = hash_table->size; + hash_size_t comfortable_size = COMFORTABLE_SIZE (needed_size); + if (size < comfortable_size) + grow_hash_table (hash_table, comfortable_size + 1); } void -puthash (CONST void *key, void *cont, c_hashtable hash) +puthash (CONST void *key, void *contents, struct hash_table *hash_table) { - unsigned int hsize = hash->size; - int (*test_function) (CONST void *, CONST void *) = hash->test_function; - unsigned int fullness = hash->fullness; + hash_table_test_function test_function = hash_table->test_function; + hash_size_t size = hash_table->size; + hash_size_t fullness = hash_table->fullness; hentry *harray; CONST void *e_key; hentry *e; unsigned int hcode_initial = - (hash->hash_function)?(hash->hash_function(key)):((unsigned long) key); + hash_table->hash_function ? + hash_table->hash_function (key) : + (unsigned long) key; unsigned int hcode; unsigned int incr = 0; - unsigned int h2; + size_t h2; CONST void *oldcontents; if (!key) { - hash->zero_entry = cont; - hash->zero_set = 1; + hash_table->zero_entry = contents; + hash_table->zero_set = 1; return; } - if (hsize < (1 + ((13 * fullness) / 10))) + if (size < (1 + COMFORTABLE_SIZE (fullness))) { - grow_hashtable (hash, hsize + 1); - hsize = hash->size; - fullness = hash->fullness; + grow_hash_table (hash_table, size + 1); + size = hash_table->size; + fullness = hash_table->fullness; } - harray= hash->harray; - h2 = hsize - 2; + harray= hash_table->harray; + h2 = size - 2; - hcode = hcode_initial % hsize; + hcode = hcode_initial % size; e_key = harray [hcode].key; - if (e_key && (KEYS_DIFFER_P (e_key, key, test_function))) + if (e_key && KEYS_DIFFER_P (e_key, key, test_function)) { - h2 = hsize - 2; + h2 = size - 2; incr = 1 + (hcode_initial % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; + if (hcode >= size) hcode -= size; e_key = harray [hcode].key; } - while (e_key && (KEYS_DIFFER_P (e_key, key, test_function))); + while (e_key && KEYS_DIFFER_P (e_key, key, test_function)); } oldcontents = harray [hcode].contents; harray [hcode].key = key; - harray [hcode].contents = cont; - /* if the entry that we used was a deleted entry, + harray [hcode].contents = contents; + /* If the entry that we used was a deleted entry, check for a non deleted entry of the same key, - then delete it */ - if (!e_key && (oldcontents == NULL_ENTRY)) + then delete it. */ + if (!e_key && oldcontents == NULL_ENTRY) { if (!incr) incr = 1 + ((unsigned long) key % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; if (hcode >= size) hcode -= size; e = &harray [hcode]; e_key = e->key; } - while ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)); + while (e_key ? + KEYS_DIFFER_P (e_key, key, test_function): + e->contents == NULL_ENTRY); if (e_key) { @@ -391,57 +353,58 @@ } /* only increment the fullness when we used up a new hentry */ - if (!e_key || (KEYS_DIFFER_P (e_key, key, test_function))) - hash->fullness++; + if (!e_key || KEYS_DIFFER_P (e_key, key, test_function)) + hash_table->fullness++; } static void -rehash (hentry *harray, c_hashtable hash, unsigned int size) +rehash (hentry *harray, struct hash_table *hash_table, hash_size_t size) { hentry *limit = harray + size; hentry *e; for (e = harray; e < limit; e++) { if (e->key) - puthash (e->key, e->contents, hash); + puthash (e->key, e->contents, hash_table); } } void -remhash (CONST void *key, c_hashtable hash) +remhash (CONST void *key, struct hash_table *hash_table) { - hentry *harray = hash->harray; - int (*test_function) (CONST void*, CONST void*) = hash->test_function; - unsigned int hsize = hash->size; + hentry *harray = hash_table->harray; + hash_table_test_function test_function = hash_table->test_function; + hash_size_t size = hash_table->size; unsigned int hcode_initial = - (hash->hash_function)?(hash->hash_function(key)):((unsigned long) key); - unsigned int hcode = hcode_initial % hsize; + (hash_table->hash_function) ? + (hash_table->hash_function (key)) : + ((unsigned long) key); + unsigned int hcode = hcode_initial % size; hentry *e = &harray [hcode]; CONST void *e_key = e->key; if (!key) { - hash->zero_entry = 0; - hash->zero_set = 0; + hash_table->zero_entry = 0; + hash_table->zero_set = 0; return; } - if ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)) + if (e_key ? + KEYS_DIFFER_P (e_key, key, test_function) : + e->contents == NULL_ENTRY) { - unsigned int h2 = hsize - 2; + size_t h2 = size - 2; unsigned int incr = 1 + (hcode_initial % h2); do { - hcode = hcode + incr; - if (hcode >= hsize) hcode = hcode - hsize; + hcode += incr; if (hcode >= size) hcode -= size; e = &harray [hcode]; e_key = e->key; } - while ((e_key)? - (KEYS_DIFFER_P (e_key, key, test_function)): - (e->contents == NULL_ENTRY)); + while (e_key? + KEYS_DIFFER_P (e_key, key, test_function): + e->contents == NULL_ENTRY); } if (e_key) { @@ -452,41 +415,38 @@ } void -maphash (maphash_function mf, c_hashtable hash, void *arg) +maphash (maphash_function mf, struct hash_table *hash_table, void *arg) { hentry *e; hentry *limit; - if (hash->zero_set) + if (hash_table->zero_set) { - if (((*mf) (0, hash->zero_entry, arg))) + if (mf (0, hash_table->zero_entry, arg)) return; } - for (e = hash->harray, limit = e + hash->size; e < limit; e++) + for (e = hash_table->harray, limit = e + hash_table->size; e < limit; e++) { - if (e->key) - { - if (((*mf) (e->key, e->contents, arg))) - return; - } + if (e->key && mf (e->key, e->contents, arg)) + return; } } void -map_remhash (remhash_predicate predicate, c_hashtable hash, void *arg) +map_remhash (remhash_predicate predicate, struct hash_table *hash_table, void *arg) { hentry *e; hentry *limit; - if (hash->zero_set && ((*predicate) (0, hash->zero_entry, arg))) + if (hash_table->zero_set && predicate (0, hash_table->zero_entry, arg)) { - hash->zero_set = 0; - hash->zero_entry = 0; + hash_table->zero_set = 0; + hash_table->zero_entry = 0; } - for (e = hash->harray, limit = e + hash->size; e < limit; e++) - if ((*predicate) (e->key, e->contents, arg)) + for (e = hash_table->harray, limit = e + hash_table->size; e < limit; e++) + if (predicate (e->key, e->contents, arg)) { e->key = 0; e->contents = NULL_ENTRY; diff -r 76b7d63099ad -r 8626e4521993 src/hash.h --- a/src/hash.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/hash.h Mon Aug 13 11:07:10 2007 +0200 @@ -26,74 +26,68 @@ 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 hash table will be grown + automatically if the number of entries approaches the size */ +struct hash_table *make_hash_table (hash_size_t size); -/* size is the number of initial entries. The hashtable will be grown - automatically if the number of entries approaches the size */ -c_hashtable make_hashtable (unsigned int size); +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_general_hashtable (unsigned int hsize, - unsigned long (*hash_function) - (CONST void *), - int (*test_function) (CONST void *, - CONST void *)); +struct hash_table *make_strings_hash_table (hash_size_t size); -c_hashtable make_strings_hashtable (unsigned int hsize); +/* Clear HASH-TABLE. A freshly created hash table is already cleared up. */ +void clrhash (struct hash_table *hash_table); -/* clears the hash table. A freshly created hashtable is already cleared up */ -void clrhash (c_hashtable hash); +/* Free HASH-TABLE and its substructures */ +void free_hash_table (struct hash_table *hash_table); -/* frees the table and substructures */ -void free_hashtable (c_hashtable hash); - -/* 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); +/* Call MF (key, contents, arg) for every entry in HASH-TABLE */ +void maphash (maphash_function mf, struct hash_table *hash_table, void* arg); -/* delete objects from the table which satisfy the predicate */ -void map_remhash (remhash_predicate predicate, c_hashtable hash, void *arg); +/* Delete all objects from HASH-TABLE satisfying PREDICATE */ +void map_remhash (remhash_predicate predicate, + 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); +/* 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); -/* makes sure that hashtable can hold at least needed_size entries */ -void expand_hashtable (c_hashtable hash, unsigned int needed_size); - -#ifdef emacs /* for elhash.c */ -unsigned int compute_harray_size (unsigned int); -#endif +/* Make sure HASH-TABLE can hold at least NEEDED_SIZE entries */ +void expand_hash_table (struct hash_table *hash_table, hash_size_t needed_size); #endif /* _HASH_H_ */ diff -r 76b7d63099ad -r 8626e4521993 src/hftctl.c --- a/src/hftctl.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/hftctl.c Mon Aug 13 11:07:10 2007 +0200 @@ -20,7 +20,7 @@ /* 1. determines if fildes is pty */ /* does normal ioctl it is not */ /* 2. places fildes into raw mode */ -/* 3. converts ioctl arguments to datastream */ +/* 3. converts ioctl arguments to data stream */ /* 4. waits for 2 secs for acknowledgement before */ /* timing out. */ /* 5. places response in callers buffer ( just like */ @@ -259,8 +259,8 @@ (i ? memcpy (&ack, p.c, i) : 0); /* if any left over, then move */ p.ack = &ack; /* ESC to front of ack struct */ - p.c += i; /* skip over whats been read */ - i = sizeof (ack) - i; /* set whats left to be read */ + p.c += i; /* skip over what's been read */ + i = sizeof (ack) - i; /* set what's left to be read */ } /***** TRY AGAIN */ alarm(0); /* ACK VTD received, reset alrm*/ diff -r 76b7d63099ad -r 8626e4521993 src/imgproc.c --- a/src/imgproc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/imgproc.c Mon Aug 13 11:07:10 2007 +0200 @@ -23,7 +23,7 @@ /* Original author: Jareth Hein */ /* Parts of this file are based on code from Sam Leffler's tiff library, - with the original copywrite displayed here: + with the original copyright displayed here: Copyright (c) 1988-1997 Sam Leffler Copyright (c) 1991-1997 Silicon Graphics, Inc. diff -r 76b7d63099ad -r 8626e4521993 src/input-method-xlib.c --- a/src/input-method-xlib.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/input-method-xlib.c Mon Aug 13 11:07:10 2007 +0200 @@ -187,10 +187,10 @@ static XtResource resources[] = { /* name class represent'n field default value */ - res(XtNximStyles, XtCXimStyles, XtRXimStyles, styles, DefaultXIMStyles), - res(XtNfontSet, XtCFontSet, XtRFontSet, fontset, XtDefaultFontSet), - res(XtNximForeground, XtCForeground, XtRPixel, fg, XtDefaultForeground), - res(XtNximBackground, XtCBackground, XtRPixel, bg, XtDefaultBackground) + res(XtNximStyles, XtCXimStyles, XtRXimStyles, styles, (XtPointer) DefaultXIMStyles), + res(XtNfontSet, XtCFontSet, XtRFontSet, fontset, (XtPointer) XtDefaultFontSet), + res(XtNximForeground, XtCForeground, XtRPixel, fg, (XtPointer) XtDefaultForeground), + res(XtNximBackground, XtCBackground, XtRPixel, bg, (XtPointer) XtDefaultBackground) }; assert (win != 0 && w != NULL && d != NULL); @@ -385,14 +385,14 @@ int i; XClientMessageEvent new_event; -try_again: +retry: len = XwcLookupString (ic, x_key_event, composed_input_buf.data, composed_input_buf.size, &keysym, &status); switch (status) { case XBufferOverflow: /* GROW_WC_STRING (&composed_input_buf, 32); mrb */ - goto try_again; + goto retry; case XLookupChars: break; default: diff -r 76b7d63099ad -r 8626e4521993 src/insdel.c --- a/src/insdel.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/insdel.c Mon Aug 13 11:07:10 2007 +0200 @@ -1886,7 +1886,7 @@ Bytecount old_gap_size; /* If we have to get more space, get enough to last a while. We use - a geometric progession that saves on realloc space. */ + a geometric progression that saves on realloc space. */ increment += 2000 + ((BI_BUF_Z (buf) - BI_BUF_BEG (buf)) / 8); if (increment > BUF_END_GAP_SIZE (buf)) @@ -3167,7 +3167,7 @@ } } -int +Charcount convert_bufbyte_string_into_emchar_string (CONST Bufbyte *str, Bytecount len, Emchar *arr) { diff -r 76b7d63099ad -r 8626e4521993 src/intl.c --- a/src/intl.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/intl.c Mon Aug 13 11:07:10 2007 +0200 @@ -123,7 +123,7 @@ insertion into the buffer of the whole string. It might require some care, though, to avoid fragmenting memory through the allocation and freeing of many small chunks. Maybe the existing system for - (single-byte) string allocation can be used, multipling the length by + (single-byte) string allocation can be used, multiplying the length by sizeof (wchar_t) to get the right size. */ void @@ -136,14 +136,14 @@ int i; XClientMessageEvent new_event; - try_again: + retry: len = XwcLookupString (context, x_key_event, composed_input_buf.data, composed_input_buf.size, &keysym, &status); switch (status) { case XBufferOverflow: /* GROW_WC_STRING (&composed_input_buf, 32); mrb */ - goto try_again; + goto retry; case XLookupChars: break; default: diff -r 76b7d63099ad -r 8626e4521993 src/keymap.c --- a/src/keymap.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/keymap.c Mon Aug 13 11:07:10 2007 +0200 @@ -30,7 +30,6 @@ #include "buffer.h" #include "bytecode.h" -#include "commands.h" #include "console.h" #include "elhash.h" #include "events.h" @@ -157,7 +156,7 @@ */ -struct keymap +typedef struct Lisp_Keymap { struct lcrecord_header header; Lisp_Object parents; /* Keymaps to be searched after this one @@ -183,12 +182,7 @@ This should be the same as the fullness of the `table', but hash.c is broken. */ Lisp_Object name; /* Just for debugging convenience */ -}; - -#define XKEYMAP(x) XRECORD (x, keymap, struct keymap) -#define XSETKEYMAP(x, p) XSETRECORD (x, p, keymap) -#define KEYMAPP(x) RECORDP (x, keymap) -#define CHECK_KEYMAP(x) CHECK_RECORD (x, keymap) +} Lisp_Keymap; #define MAKE_MODIFIER_HASH_KEY(modifier) make_int (modifier) #define MODIFIER_HASH_KEY_BITS(x) (INTP (x) ? XINT (x) : 0) @@ -260,13 +254,13 @@ static Lisp_Object mark_keymap (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct keymap *keymap = XKEYMAP (obj); - ((markobj) (keymap->parents)); - ((markobj) (keymap->prompt)); - ((markobj) (keymap->inverse_table)); - ((markobj) (keymap->sub_maps_cache)); - ((markobj) (keymap->default_binding)); - ((markobj) (keymap->name)); + Lisp_Keymap *keymap = XKEYMAP (obj); + markobj (keymap->parents); + markobj (keymap->prompt); + markobj (keymap->inverse_table); + markobj (keymap->sub_maps_cache); + markobj (keymap->default_binding); + markobj (keymap->name); return keymap->table; } @@ -274,7 +268,7 @@ print_keymap (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { /* This function can GC */ - struct keymap *keymap = XKEYMAP (obj); + Lisp_Keymap *keymap = XKEYMAP (obj); char buf[200]; int size = XINT (Fkeymap_fullness (obj)); if (print_readably) @@ -294,7 +288,7 @@ /* No need for keymap_equal #### Why not? */ DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap, mark_keymap, print_keymap, 0, 0, 0, - struct keymap); + Lisp_Keymap); /************************************************************************/ /* Traversing keymaps and their parents */ @@ -475,7 +469,7 @@ keymap_lookup_directly (Lisp_Object keymap, Lisp_Object keysym, unsigned int modifiers) { - struct keymap *k; + Lisp_Keymap *k; if ((modifiers & ~(MOD_CONTROL | MOD_META | MOD_SUPER | MOD_HYPER | MOD_ALT | MOD_SHIFT)) != 0) @@ -534,7 +528,7 @@ } else { - while (CONSP (Fcdr (keys))) + while (CONSP (XCDR (keys))) keys = XCDR (keys); XCDR (keys) = Fcons (XCDR (keys), keysym); /* No need to call puthash because we've destructively @@ -584,7 +578,7 @@ static void -keymap_store_internal (Lisp_Object keysym, struct keymap *keymap, +keymap_store_internal (Lisp_Object keysym, Lisp_Keymap *keymap, Lisp_Object value) { Lisp_Object prev_value = Fgethash (keysym, keymap->table, Qnil); @@ -613,7 +607,7 @@ static Lisp_Object -create_bucky_submap (struct keymap *k, unsigned int modifiers, +create_bucky_submap (Lisp_Keymap *k, unsigned int modifiers, Lisp_Object parent_for_debugging_info) { Lisp_Object submap = Fmake_sparse_keymap (Qnil); @@ -634,7 +628,7 @@ { Lisp_Object keysym = key->keysym; unsigned int modifiers = key->modifiers; - struct keymap *k; + Lisp_Keymap *k; if ((modifiers & ~(MOD_CONTROL | MOD_META | MOD_SUPER | MOD_HYPER | MOD_ALT | MOD_SHIFT)) != 0) @@ -683,32 +677,27 @@ }; static int -keymap_submaps_mapper_0 (CONST void *hash_key, void *hash_contents, +keymap_submaps_mapper_0 (Lisp_Object key, Lisp_Object value, void *keymap_submaps_closure) { /* This function can GC */ - Lisp_Object contents; - VOID_TO_LISP (contents, hash_contents); /* Perform any autoloads, etc */ - Fkeymapp (contents); + Fkeymapp (value); return 0; } static int -keymap_submaps_mapper (CONST void *hash_key, void *hash_contents, +keymap_submaps_mapper (Lisp_Object key, Lisp_Object value, void *keymap_submaps_closure) { /* This function can GC */ - Lisp_Object key, contents; Lisp_Object *result_locative; struct keymap_submaps_closure *cl = (struct keymap_submaps_closure *) keymap_submaps_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); result_locative = cl->result_locative; - if (!NILP (Fkeymapp (contents))) - *result_locative = Fcons (Fcons (key, contents), *result_locative); + if (!NILP (Fkeymapp (value))) + *result_locative = Fcons (Fcons (key, value), *result_locative); return 0; } @@ -719,7 +708,7 @@ keymap_submaps (Lisp_Object keymap) { /* This function can GC */ - struct keymap *k = XKEYMAP (keymap); + Lisp_Keymap *k = XKEYMAP (keymap); if (EQ (k->sub_maps_cache, Qt)) /* Unknown */ { @@ -750,28 +739,31 @@ /************************************************************************/ static Lisp_Object -make_keymap (int size) +make_keymap (size_t size) { Lisp_Object result; - struct keymap *keymap = alloc_lcrecord_type (struct keymap, lrecord_keymap); + Lisp_Keymap *keymap = alloc_lcrecord_type (Lisp_Keymap, lrecord_keymap); XSETKEYMAP (result, keymap); - keymap->parents = Qnil; - keymap->table = Qnil; - keymap->prompt = Qnil; + keymap->parents = Qnil; + keymap->prompt = Qnil; + keymap->table = Qnil; + keymap->inverse_table = Qnil; keymap->default_binding = Qnil; - keymap->inverse_table = Qnil; - keymap->sub_maps_cache = Qnil; /* No possible submaps */ - keymap->fullness = 0; + keymap->sub_maps_cache = Qnil; /* No possible submaps */ + keymap->fullness = 0; + keymap->name = Qnil; + if (size != 0) /* hack for copy-keymap */ { - keymap->table = Fmake_hashtable (make_int (size), Qnil); + keymap->table = + make_lisp_hash_table (size, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); /* Inverse table is often less dense because of duplicate key-bindings. If not, it will grow anyway. */ - keymap->inverse_table = Fmake_hashtable (make_int (size * 3 / 4), Qnil); + keymap->inverse_table = + make_lisp_hash_table (size * 3 / 4, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); } - keymap->name = Qnil; return result; } @@ -1114,38 +1106,34 @@ }; static int -copy_keymap_inverse_mapper (CONST void *hash_key, void *hash_contents, +copy_keymap_inverse_mapper (Lisp_Object key, Lisp_Object value, void *copy_keymap_inverse_closure) { - Lisp_Object key, inverse_table, inverse_contents; struct copy_keymap_inverse_closure *closure = (struct copy_keymap_inverse_closure *) copy_keymap_inverse_closure; - VOID_TO_LISP (inverse_table, closure); - VOID_TO_LISP (inverse_contents, hash_contents); - CVOID_TO_LISP (key, hash_key); /* copy-sequence deals with dotted lists. */ - if (CONSP (inverse_contents)) - inverse_contents = Fcopy_sequence (inverse_contents); - Fputhash (key, inverse_contents, closure->inverse_table); + if (CONSP (value)) + value = Fcopy_list (value); + Fputhash (key, value, closure->inverse_table); return 0; } static Lisp_Object -copy_keymap_internal (struct keymap *keymap) +copy_keymap_internal (Lisp_Keymap *keymap) { Lisp_Object nkm = make_keymap (0); - struct keymap *new_keymap = XKEYMAP (nkm); + Lisp_Keymap *new_keymap = XKEYMAP (nkm); struct copy_keymap_inverse_closure copy_keymap_inverse_closure; copy_keymap_inverse_closure.inverse_table = keymap->inverse_table; - new_keymap->parents = Fcopy_sequence (keymap->parents); - new_keymap->fullness = keymap->fullness; + new_keymap->parents = Fcopy_sequence (keymap->parents); + new_keymap->fullness = keymap->fullness; new_keymap->sub_maps_cache = Qnil; /* No submaps */ - new_keymap->table = Fcopy_hashtable (keymap->table); - new_keymap->inverse_table = Fcopy_hashtable (keymap->inverse_table); + new_keymap->table = Fcopy_hash_table (keymap->table); + new_keymap->inverse_table = Fcopy_hash_table (keymap->inverse_table); /* After copying the inverse map, we need to copy the conses which are its values, lest they be shared by the copy, and mangled. */ @@ -1159,30 +1147,26 @@ struct copy_keymap_closure { - struct keymap *self; + Lisp_Keymap *self; }; static int -copy_keymap_mapper (CONST void *hash_key, void *hash_contents, +copy_keymap_mapper (Lisp_Object key, Lisp_Object value, void *copy_keymap_closure) { /* This function can GC */ - Lisp_Object key, contents; struct copy_keymap_closure *closure = (struct copy_keymap_closure *) copy_keymap_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); /* When we encounter a keymap which is indirected through a symbol, we need to copy the sub-map. In v18, the form (lookup-key (copy-keymap global-map) "\C-x") returned a new keymap, not the symbol 'Control-X-prefix. */ - contents = get_keymap (contents, - 0, 1); /* #### autoload GC-safe here? */ - if (KEYMAPP (contents)) + value = get_keymap (value, 0, 1); /* #### autoload GC-safe here? */ + if (KEYMAPP (value)) keymap_store_internal (key, closure->self, - copy_keymap (contents)); + copy_keymap (value)); return 0; } @@ -1284,12 +1268,12 @@ /* #### This bites! I want to be able to write (control shift a) */ if (modifiers & MOD_SHIFT) signal_simple_error - ("the `shift' modifier may not be applied to ASCII keysyms", + ("The `shift' modifier may not be applied to ASCII keysyms", spec); } else { - signal_simple_error ("unknown keysym specifier", + signal_simple_error ("Unknown keysym specifier", *keysym); } @@ -1474,19 +1458,19 @@ if (!NILP (XCDR (rest))) { if (! modifier) - signal_simple_error ("unknown modifier", keysym); + signal_simple_error ("Unknown modifier", keysym); } else { if (modifier) - signal_simple_error ("nothing but modifiers here", + signal_simple_error ("Nothing but modifiers here", spec); } rest = XCDR (rest); QUIT; } if (!NILP (rest)) - signal_simple_error ("dotted list", spec); + signal_simple_error ("List must be nil-terminated", spec); define_key_check_and_coerce_keysym (spec, &keysym, modifiers); returned_value->keysym = keysym; @@ -1494,7 +1478,7 @@ } else { - signal_simple_error ("unknown key-sequence specifier", + signal_simple_error ("Unknown key-sequence specifier", spec); } } @@ -1513,7 +1497,7 @@ { Lisp_Object fn, arg; if (! NILP (Fcdr (Fcdr (list)))) - signal_simple_error ("invalid menu event desc", list); + signal_simple_error ("Invalid menu event desc", list); arg = Fcar (Fcdr (list)); if (SYMBOLP (arg)) fn = Qcall_interactively; @@ -1621,6 +1605,12 @@ ? Qt : Qnil); } +#define MACROLET(k,m) do { \ + returned_value->keysym = (k); \ + returned_value->modifiers = (m); \ + RETURN_SANS_WARNINGS; \ +} while (0) + /* ASCII grunge. Given a keysym, return another keysym/modifier pair which could be considered the same key in an ASCII world. Backspace returns ^H, for @@ -1636,9 +1626,6 @@ unsigned int modifiers_sans_meta = (modifiers & (~MOD_META)); returned_value->keysym = Qnil; /* By default, no "alternate" key */ returned_value->modifiers = 0; -#define MACROLET(k,m) do { returned_value->keysym = (k); \ - returned_value->modifiers = (m); \ - RETURN__; } while (0) if (modifiers_sans_meta == MOD_CONTROL) { if EQ (keysym, QKspace) @@ -1970,7 +1957,7 @@ keymap_store (keymap, &raw_key1, cmd); } if (NILP (Fkeymapp (cmd))) - signal_simple_error_2 ("invalid prefix keys in sequence", + signal_simple_error_2 ("Invalid prefix keys in sequence", c, keys); if (ascii_hack && !NILP (raw_key2.keysym) && @@ -2057,7 +2044,7 @@ * element is the meta-prefix-char will return the keymap that * the "meta" keys are stored in, if there is no binding for * the meta-prefix-char (and if this map has a "meta" submap). - * If this map doesnt have a "meta" submap, then the + * If this map doesn't have a "meta" submap, then the * meta-prefix-char is looked up just like any other key. */ if (remaining == 0) @@ -2226,7 +2213,7 @@ map of the buffer in which the mouse was clicked in event0 is a click. It would be kind of nice if this were in Lisp so that this semi-hairy - semi-heuristic command-lookup behaviour could be readily understood and + semi-heuristic command-lookup behavior could be readily understood and customised. However, this needs to be pretty fast, or performance of keyboard macros goes to shit; putting this in lisp slows macros down 2-3x. And they're already slower than v18 by 5-6x. @@ -2410,7 +2397,7 @@ { int nmaps = closure.nmaps; - /* Silently truncate at 100 keymaps to prevent infinite losssage */ + /* Silently truncate at 100 keymaps to prevent infinite lossage */ if (nmaps >= max_maps && max_maps > 0) maps[max_maps - 1] = Vcurrent_global_map; else @@ -2426,7 +2413,7 @@ first element in the list returned. This is so we can correctly search the keymaps associated with glyphs which may be physically disjoint from their extents: for example, if a glyph is out in the - margin, we should still consult the kemyap of that glyph's extent, + margin, we should still consult the keymap of that glyph's extent, which may not itself be under the mouse. */ @@ -2751,26 +2738,22 @@ /* used by map_keymap() */ static int -map_keymap_unsorted_mapper (CONST void *hash_key, void *hash_contents, +map_keymap_unsorted_mapper (Lisp_Object keysym, Lisp_Object value, void *map_keymap_unsorted_closure) { /* This function can GC */ - Lisp_Object keysym; - Lisp_Object contents; struct map_keymap_unsorted_closure *closure = (struct map_keymap_unsorted_closure *) map_keymap_unsorted_closure; unsigned int modifiers = closure->modifiers; unsigned int mod_bit; - CVOID_TO_LISP (keysym, hash_key); - VOID_TO_LISP (contents, hash_contents); mod_bit = MODIFIER_HASH_KEY_BITS (keysym); if (mod_bit != 0) { int omod = modifiers; closure->modifiers = (modifiers | mod_bit); - contents = get_keymap (contents, 1, 0); + value = get_keymap (value, 1, 0); elisp_maphash (map_keymap_unsorted_mapper, - XKEYMAP (contents)->table, + XKEYMAP (value)->table, map_keymap_unsorted_closure); closure->modifiers = omod; } @@ -2779,7 +2762,7 @@ struct key_data key; key.keysym = keysym; key.modifiers = modifiers; - ((*closure->fn) (&key, contents, closure->arg)); + ((*closure->fn) (&key, value, closure->arg)); } return 0; } @@ -2792,16 +2775,13 @@ /* used by map_keymap_sorted() */ static int -map_keymap_sorted_mapper (CONST void *hash_key, void *hash_contents, +map_keymap_sorted_mapper (Lisp_Object key, Lisp_Object value, void *map_keymap_sorted_closure) { struct map_keymap_sorted_closure *cl = (struct map_keymap_sorted_closure *) map_keymap_sorted_closure; - Lisp_Object key, contents; Lisp_Object *list = cl->result_locative; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - *list = Fcons (Fcons (key, contents), *list); + *list = Fcons (Fcons (key, value), *list); return 0; } @@ -2899,7 +2879,7 @@ struct gcpro gcpro1; Lisp_Object contents = Qnil; - if (XINT (Fhashtable_fullness (keymap_table)) == 0) + if (XINT (Fhash_table_count (keymap_table)) == 0) return; GCPRO1 (contents); @@ -3269,7 +3249,7 @@ #endif strcpy (bufp, (char *) string_data (XSYMBOL (keysym)->name)); if (!NILP (XCDR (rest))) - signal_simple_error ("invalid key description", + signal_simple_error ("Invalid key description", key); } } @@ -3752,7 +3732,7 @@ } -/* Insert a desription of the key bindings in STARTMAP, +/* Insert a description of the key bindings in STARTMAP, followed by those of all maps reachable through STARTMAP. If PARTIAL is nonzero, omit certain "uninteresting" commands (such as `undefined'). @@ -3936,7 +3916,7 @@ Lisp_Object keysym = key->keysym; unsigned int modifiers = key->modifiers; - /* Dont mention suppressed commands. */ + /* Don't mention suppressed commands. */ if (SYMBOLP (binding) && !NILP (closure->partial) && !NILP (Fget (binding, closure->partial, Qnil))) @@ -4143,7 +4123,7 @@ { Lisp_Object code = Fget (keysym, Vcharacter_set_property, Qnil); Emchar c = (CHAR_OR_CHAR_INTP (code) - ? XCHAR_OR_CHAR_INT (code) : -1); + ? XCHAR_OR_CHAR_INT (code) : (Emchar) -1); /* Calling Fsingle_key_description() would cons more */ #if 0 /* This is bogus */ if (EQ (keysym, QKlinefeed)) diff -r 76b7d63099ad -r 8626e4521993 src/keymap.h --- a/src/keymap.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/keymap.h Mon Aug 13 11:07:10 2007 +0200 @@ -24,8 +24,8 @@ #ifndef _XEMACS_KEYMAP_H_ #define _XEMACS_KEYMAP_H_ -DECLARE_LRECORD (keymap, struct keymap); -#define XKEYMAP(x) XRECORD (x, keymap, struct keymap) +DECLARE_LRECORD (keymap, struct Lisp_Keymap); +#define XKEYMAP(x) XRECORD (x, keymap, struct Lisp_Keymap) #define XSETKEYMAP(x, p) XSETRECORD (x, p, keymap) #define KEYMAPP(x) RECORDP (x, keymap) #define GC_KEYMAPP(x) GC_RECORDP (x, keymap) diff -r 76b7d63099ad -r 8626e4521993 src/line-number.c --- a/src/line-number.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/line-number.c Mon Aug 13 11:07:10 2007 +0200 @@ -52,7 +52,6 @@ #include #include "lisp.h" #include "buffer.h" -#include "insdel.h" #include "line-number.h" @@ -81,7 +80,7 @@ /* Initialize the cache. Cache is (in pseudo-BNF): CACHE = nil | INITIALIZED-CACHE - INITITIALIZED-CACHE = cons (RING, BEGV-LINE) + INITIALIZED-CACHE = cons (RING, BEGV-LINE) RING = vector (*RING-ELEMENT) RING-ELEMENT = nil | RING-PAIR RING-PAIR = cons (marker, integer) diff -r 76b7d63099ad -r 8626e4521993 src/linuxplay.c --- a/src/linuxplay.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/linuxplay.c Mon Aug 13 11:07:10 2007 +0200 @@ -820,7 +820,7 @@ perror("SNDCTL_DSP_SYNC"); return(0); } - /* Initialize sound hardware with prefered parameters */ + /* Initialize sound hardware with preferred parameters */ /* If the sound hardware cannot support 16 bit format or requires a different byte sex then try to drop to 8 bit format */ @@ -993,9 +993,8 @@ return; } /* The VoxWare-SDK discourages opening /dev/audio; opening /dev/dsp and - properly intializing it via ioctl() is prefered */ - if ((audio_fd=open(audio_dev, - (O_WRONLY|O_NDELAY),0)) < 0) { + properly initializing it via ioctl() is preferred */ + if ((audio_fd=open(audio_dev, O_WRONLY | O_NONBLOCK, 0)) < 0) { perror(audio_dev); if (mix_fd > 0 && mix_fd != audio_fd) { close(mix_fd); mix_fd = -1; } return; } diff -r 76b7d63099ad -r 8626e4521993 src/lisp-disunion.h --- a/src/lisp-disunion.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/lisp-disunion.h Mon Aug 13 11:07:10 2007 +0200 @@ -109,10 +109,11 @@ #ifdef USE_MINIMAL_TAGBITS +# define Lisp_Type_Int_Bit (Lisp_Type_Int_Even & Lisp_Type_Int_Odd) # define XUNMARK(x) DO_NOTHING # define make_obj(vartype, x) ((Lisp_Object) (x)) -# define make_int(x) ((Lisp_Object) (((x) << INT_GCBITS) + 1)) -# define make_char(x) ((Lisp_Object) (((x) << GCBITS) + Lisp_Type_Char)) +# define make_int(x) ((Lisp_Object) (((x) << INT_GCBITS) | Lisp_Type_Int_Bit)) +# define make_char(x) ((Lisp_Object) (((x) << GCBITS) | Lisp_Type_Char)) # define VALMASK (((1UL << VALBITS) - 1UL) << GCTYPEBITS) # define XTYPE(x) ((enum Lisp_Type) (((EMACS_UINT)(x)) & ~VALMASK)) # define XPNTRVAL(x) (x) /* This depends on Lisp_Type_Record == 0 */ @@ -120,8 +121,7 @@ # define GC_EQ(x,y) EQ (x,y) # define XREALINT(x) ((x) >> INT_GCBITS) # define XUINT(x) ((EMACS_UINT)(x) >> INT_GCBITS) -# define INTP(x) ((EMACS_UINT)(x) & 1) -# define Qzero ((Lisp_Object) 1UL) +# define INTP(x) ((EMACS_UINT)(x) & Lisp_Type_Int_Bit) #else /* !USE_MINIMAL_TAGBITS */ @@ -142,11 +142,11 @@ # define XREALINT(x) (((x) << INT_GCBITS) >> INT_GCBITS) # define XUINT(x) ((EMACS_UINT) ((x) & VALMASK)) # define INTP(x) (XTYPE (x) == Lisp_Type_Int) -# define Qzero ((Lisp_Object) Lisp_Type_Int) #endif /* !USE_MINIMAL_TAGBITS */ -#define Qnull_pointer 0 +#define Qzero make_int (0) +#define Qnull_pointer ((Lisp_Object) 0) #define XGCTYPE(x) XTYPE(x) #define EQ(x,y) ((x) == (y)) #define XSETINT(var, value) ((void) ((var) = make_int (value))) diff -r 76b7d63099ad -r 8626e4521993 src/lisp-union.h --- a/src/lisp-union.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/lisp-union.h Mon Aug 13 11:07:10 2007 +0200 @@ -89,29 +89,38 @@ #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) \ - ((void) ((var).ui = (EMACS_UINT) (value))) +# define XSETOBJ(var, vartype, value) do { \ + EMACS_UINT xset_value = (EMACS_UINT) (value); \ + (var).ui = xset_value; \ +} while (0) # define XPNTRVAL(x) ((x).ui) + #else /* ! USE_MINIMAL_TAGBITS */ + # define XSETOBJ(var, vartype, value) do { \ - Lisp_Object *_xzx = &(var); \ - _xzx->gu.val = (EMACS_UINT) (value); \ - _xzx->gu.type = (vartype); \ - _xzx->gu.markbit = 0; \ + EMACS_UINT xset_value = (EMACS_UINT) (value); \ + Lisp_Object *xset_var = &(var); \ + xset_var->gu.type = (vartype); \ + xset_var->gu.markbit = 0; \ + xset_var->gu.val = xset_value; \ } while (0) # define XSETINT(var, value) XSETOBJ (var, Lisp_Type_Int, value) # define XSETCHAR(var, value) XSETOBJ (var, Lisp_Type_Char, value) # define XPNTRVAL(x) ((x).gu.val) + #endif /* ! USE_MINIMAL_TAGBITS */ INLINE Lisp_Object make_int (EMACS_INT val); diff -r 76b7d63099ad -r 8626e4521993 src/lisp.h --- a/src/lisp.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/lisp.h Mon Aug 13 11:07:10 2007 +0200 @@ -26,7 +26,7 @@ #define _XEMACS_LISP_H_ /************************************************************************/ -/* general definitions */ +/* general definitions */ /************************************************************************/ /* We include the following generally useful header files so that you @@ -181,7 +181,7 @@ # define DOESNT_RETURN void volatile # define DECLARE_DOESNT_RETURN(decl) \ extern void volatile decl __attribute__ ((noreturn)) -# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \ +# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \ /* Should be able to state multiple independent __attribute__s, but \ the losing syntax doesn't work that way, and screws losing cpp */ \ extern void volatile decl \ @@ -189,13 +189,13 @@ # else # define DOESNT_RETURN void volatile # define DECLARE_DOESNT_RETURN(decl) extern void volatile decl -# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \ +# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \ extern void volatile decl PRINTF_ARGS(str,idx) # endif /* GNUC 2.5 */ # else # define DOESNT_RETURN void # define DECLARE_DOESNT_RETURN(decl) extern void decl -# define DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS(decl,str,idx) \ +# define DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS(decl,str,idx) \ extern void decl PRINTF_ARGS(str,idx) # endif /* GNUC */ #endif @@ -215,15 +215,6 @@ #define ALIGN_PTR(ptr, unit) \ ((void *) ALIGN_SIZE ((long) (ptr), unit)) -#ifdef QUANTIFY -#include "quantify.h" -#define QUANTIFY_START_RECORDING quantify_start_recording_data () -#define QUANTIFY_STOP_RECORDING quantify_stop_recording_data () -#else /* !QUANTIFY */ -#define QUANTIFY_START_RECORDING -#define QUANTIFY_STOP_RECORDING -#endif /* !QUANTIFY */ - #ifndef DO_NOTHING #define DO_NOTHING do {} while (0) #endif @@ -260,7 +251,7 @@ /************************************************************************/ -/* typedefs */ +/* typedefs */ /************************************************************************/ /* We put typedefs here so that prototype declarations don't choke. @@ -333,12 +324,18 @@ struct frame; /* "frame.h" */ struct window; /* "window.h" */ struct Lisp_Event; /* "events.h" */ +typedef struct Lisp_Event Lisp_Event; struct Lisp_Face; +typedef struct Lisp_Face Lisp_Face; struct Lisp_Process; /* "process.c" */ +typedef struct Lisp_Process Lisp_Process; struct stat; /* */ struct Lisp_Color_Instance; +typedef struct Lisp_Color_Instance Lisp_Color_Instance; struct Lisp_Font_Instance; +typedef struct Lisp_Font_Instance Lisp_Font_Instance; struct Lisp_Image_Instance; +typedef struct Lisp_Image_Instance Lisp_Image_Instance; struct display_line; struct redisplay_info; struct window_mirror; @@ -506,7 +503,7 @@ /************************************************************************/ -/* Definition of Lisp_Object data type */ +/* Definition of Lisp_Object data type */ /************************************************************************/ #ifdef USE_MINIMAL_TAGBITS @@ -524,14 +521,14 @@ enum Lisp_Type { + /* XRECORD_LHEADER (object) points to a struct lrecord_header + lheader->implementation determines the type (and GC behavior) + of the object. */ + Lisp_Type_Record, + /* 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) - of the object. */ - Lisp_Type_Record, - #ifndef LRECORD_CONS /* Cons. XCONS (object) points to a struct Lisp_Cons. */ Lisp_Type_Cons, @@ -574,22 +571,28 @@ #endif /* USE_MINIMAL_TAGBITS */ -/* This should be the underlying type into which a Lisp_Object must fit. - In a strict ANSI world, this must be `int', since ANSI says you can't - use bitfields on any type other than `int'. However, on a machine - where `int' and `long' are not the same size, this should be the - longer of the two. (This also must be something into which a pointer - to an arbitrary object will fit, modulo any DATA_SEG_BITS cruft.) - */ -/* ### We should be using uintptr_t and SIZEOF_VOID_P here */ -#if (LONGBITS > INTBITS) -# define EMACS_INT long -# define EMACS_UINT unsigned long -# define SIZEOF_EMACS_INT SIZEOF_LONG -#else -# define EMACS_INT int -# define EMACS_UINT unsigned int -# define SIZEOF_EMACS_INT SIZEOF_INT +/* EMACS_INT is the underlying integral type into which a Lisp_Object must fit. + In particular, it must be large enough to contain a pointer. + config.h can override this, e.g. to use `long long' for bigger lisp ints. */ + +#ifndef SIZEOF_EMACS_INT +# define SIZEOF_EMACS_INT SIZEOF_VOID_P +#endif + +#ifndef EMACS_INT +# if SIZEOF_EMACS_INT == SIZEOF_LONG +# define EMACS_INT long +# elif SIZEOF_EMACS_INT == SIZEOF_INT +# define EMACS_INT int +# elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG +# define EMACS_INT long long +# else +# error Unable to determine suitable type for EMACS_INT +# endif +#endif + +#ifndef EMACS_UINT +# define EMACS_UINT unsigned EMACS_INT #endif #define BITS_PER_EMACS_INT (SIZEOF_EMACS_INT * BITS_PER_CHAR) @@ -669,12 +672,12 @@ /************************************************************************/ -/* Definitions of basic Lisp objects */ +/* Definitions of basic Lisp objects */ /************************************************************************/ #include "lrecord.h" -/********** unbound ***********/ +/*********** unbound ***********/ /* Qunbound is a special Lisp_Object (actually of type symbol-value-forward), that can never be visible to @@ -695,6 +698,7 @@ #endif Lisp_Object car, cdr; }; +typedef struct Lisp_Cons Lisp_Cons; #if 0 /* FSFmacs */ /* Like a cons, but records info on where the text lives that it was read from */ @@ -710,8 +714,8 @@ #ifdef LRECORD_CONS -DECLARE_LRECORD (cons, struct Lisp_Cons); -#define XCONS(x) XRECORD (x, cons, struct Lisp_Cons) +DECLARE_LRECORD (cons, Lisp_Cons); +#define XCONS(x) XRECORD (x, cons, Lisp_Cons) #define XSETCONS(x, p) XSETRECORD (x, p, cons) #define CONSP(x) RECORDP (x, cons) #define GC_CONSP(x) GC_RECORDP (x, cons) @@ -723,8 +727,8 @@ #else /* ! LRECORD_CONS */ -DECLARE_NONRECORD (cons, Lisp_Type_Cons, struct Lisp_Cons); -#define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, struct Lisp_Cons) +DECLARE_NONRECORD (cons, Lisp_Type_Cons, Lisp_Cons); +#define XCONS(a) XNONRECORD (a, cons, Lisp_Type_Cons, Lisp_Cons) #define XSETCONS(c, p) XSETOBJ (c, Lisp_Type_Cons, p) #define CONSP(x) (XTYPE (x) == Lisp_Type_Cons) #define GC_CONSP(x) (XGCTYPE (x) == Lisp_Type_Cons) @@ -738,6 +742,8 @@ #endif /* ! LRECORD_CONS */ +extern Lisp_Object Qnil; + #define NILP(x) EQ (x, Qnil) #define GC_NILP(x) GC_EQ (x, Qnil) #define XCAR(a) (XCONS (a)->car) @@ -756,78 +762,312 @@ /* 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; - + +/* 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 + + +/* 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 PLIST. + + We have to be tricky to still keep the same C format.*/ +#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) { - while (CONSP (object)) - object = XCDR (object); - return NILP (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); } -#define CHECK_TRUE_LIST(object) do { \ - if (!TRUE_LIST_P (object)) \ - dead_wrong_type_argument (Qtrue_list_p, object); \ +/* 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) -/* 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. - - 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); \ - else - /*********** string ***********/ -/* In a string or vector, the sign bit of the `size' is the gc mark bit */ - -/* (The size and data fields have underscores prepended to catch old - code that attempts to reference the fields directly) */ +/* In a string, the markbit of the plist is used as the gc mark bit */ + struct Lisp_String { #ifdef LRECORD_STRING struct lrecord_header lheader; #endif - Bytecount _size; - Bufbyte *_data; + Bytecount size; + Bufbyte *data; Lisp_Object plist; }; +typedef struct Lisp_String Lisp_String; #ifdef LRECORD_STRING -DECLARE_LRECORD (string, struct Lisp_String); -#define XSTRING(x) XRECORD (x, string, struct Lisp_String) +DECLARE_LRECORD (string, Lisp_String); +#define XSTRING(x) XRECORD (x, string, Lisp_String) #define XSETSTRING(x, p) XSETRECORD (x, p, string) #define STRINGP(x) RECORDP (x, string) #define GC_STRINGP(x) GC_RECORDP (x, string) @@ -836,8 +1076,8 @@ #else /* ! LRECORD_STRING */ -DECLARE_NONRECORD (string, Lisp_Type_String, struct Lisp_String); -#define XSTRING(x) XNONRECORD (x, string, Lisp_Type_String, struct Lisp_String) +DECLARE_NONRECORD (string, Lisp_Type_String, Lisp_String); +#define XSTRING(x) XNONRECORD (x, string, Lisp_Type_String, Lisp_String) #define XSETSTRING(x, p) XSETOBJ (x, Lisp_Type_String, p) #define STRINGP(x) (XTYPE (x) == Lisp_Type_String) #define GC_STRINGP(x) (XGCTYPE (x) == Lisp_Type_String) @@ -858,32 +1098,32 @@ #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))) - -void resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta); +#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 (Lisp_String *s, Bytecount pos, Bytecount delta); #ifdef MULE -INLINE Charcount string_char_length (struct Lisp_String *s); +INLINE Charcount string_char_length (Lisp_String *s); INLINE Charcount -string_char_length (struct Lisp_String *s) +string_char_length (Lisp_String *s) { return bytecount_to_charcount (string_data (s), string_length (s)); } # define string_char(s, i) charptr_emchar_n (string_data (s), i) # define string_char_addr(s, i) charptr_n_addr (string_data (s), i) -void set_string_char (struct Lisp_String *s, Charcount i, Emchar c); +void set_string_char (Lisp_String *s, Charcount i, Emchar c); #else /* not MULE */ @@ -907,11 +1147,12 @@ /* struct Lisp_Vector *next; */ Lisp_Object contents[1]; }; +typedef struct Lisp_Vector Lisp_Vector; #ifdef LRECORD_VECTOR -DECLARE_LRECORD (vector, struct Lisp_Vector); -#define XVECTOR(x) XRECORD (x, vector, struct Lisp_Vector) +DECLARE_LRECORD (vector, Lisp_Vector); +#define XVECTOR(x) XRECORD (x, vector, Lisp_Vector) #define XSETVECTOR(x, p) XSETRECORD (x, p, vector) #define VECTORP(x) RECORDP (x, vector) #define GC_VECTORP(x) GC_RECORDP (x, vector) @@ -920,8 +1161,8 @@ #else -DECLARE_NONRECORD (vector, Lisp_Type_Vector, struct Lisp_Vector); -#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Type_Vector, struct Lisp_Vector) +DECLARE_NONRECORD (vector, Lisp_Type_Vector, Lisp_Vector); +#define XVECTOR(x) XNONRECORD (x, vector, Lisp_Type_Vector, Lisp_Vector) #define XSETVECTOR(x, p) XSETOBJ (x, Lisp_Type_Vector, p) #define VECTORP(x) (XTYPE (x) == Lisp_Type_Vector) #define GC_VECTORP(x) (XGCTYPE (x) == Lisp_Type_Vector) @@ -959,12 +1200,13 @@ { struct lrecord_header lheader; Lisp_Object next; - long size; + size_t size; unsigned long bits[1]; }; - -DECLARE_LRECORD (bit_vector, struct Lisp_Bit_Vector); -#define XBIT_VECTOR(x) XRECORD (x, bit_vector, struct Lisp_Bit_Vector) +typedef struct Lisp_Bit_Vector Lisp_Bit_Vector; + +DECLARE_LRECORD (bit_vector, Lisp_Bit_Vector); +#define XBIT_VECTOR(x) XRECORD (x, bit_vector, Lisp_Bit_Vector) #define XSETBIT_VECTOR(x, p) XSETRECORD (x, p, bit_vector) #define BIT_VECTORP(x) RECORDP (x, bit_vector) #define GC_BIT_VECTORP(x) GC_RECORDP (x, bit_vector) @@ -987,9 +1229,9 @@ #define bit_vector_length(v) ((v)->size) #define bit_vector_next(v) ((v)->next) -INLINE int bit_vector_bit (struct Lisp_Bit_Vector *v, int i); +INLINE int bit_vector_bit (Lisp_Bit_Vector *v, int i); INLINE int -bit_vector_bit (struct Lisp_Bit_Vector *v, int i) +bit_vector_bit (Lisp_Bit_Vector *v, int i) { unsigned int ui = (unsigned int) i; @@ -997,15 +1239,15 @@ & 1); } -INLINE void set_bit_vector_bit (struct Lisp_Bit_Vector *v, int i, int value); +INLINE void set_bit_vector_bit (Lisp_Bit_Vector *v, int i, int value); INLINE void -set_bit_vector_bit (struct Lisp_Bit_Vector *v, int i, int value) +set_bit_vector_bit (Lisp_Bit_Vector *v, int i, int value) { unsigned int ui = (unsigned int) i; if (value) - (v)->bits[ui >> LONGBITS_LOG2] |= (1 << (ui & (LONGBITS_POWER_OF_2 - 1))); + (v)->bits[ui >> LONGBITS_LOG2] |= (1U << (ui & (LONGBITS_POWER_OF_2 - 1))); else - (v)->bits[ui >> LONGBITS_LOG2] &= ~(1 << (ui & (LONGBITS_POWER_OF_2 - 1))); + (v)->bits[ui >> LONGBITS_LOG2] &= ~(1U << (ui & (LONGBITS_POWER_OF_2 - 1))); } /* Number of longs required to hold LEN bits */ @@ -1031,14 +1273,15 @@ Lisp_Object obarray; Lisp_Object plist; }; +typedef struct Lisp_Symbol Lisp_Symbol; #define SYMBOL_IS_KEYWORD(sym) (string_byte (XSYMBOL(sym)->name, 0) == ':') #define KEYWORDP(obj) (SYMBOLP (obj) && SYMBOL_IS_KEYWORD (obj)) #ifdef LRECORD_SYMBOL -DECLARE_LRECORD (symbol, struct Lisp_Symbol); -#define XSYMBOL(x) XRECORD (x, symbol, struct Lisp_Symbol) +DECLARE_LRECORD (symbol, Lisp_Symbol); +#define XSYMBOL(x) XRECORD (x, symbol, Lisp_Symbol) #define XSETSYMBOL(x, p) XSETRECORD (x, p, symbol) #define SYMBOLP(x) RECORDP (x, symbol) #define GC_SYMBOLP(x) GC_RECORDP (x, symbol) @@ -1047,8 +1290,8 @@ #else -DECLARE_NONRECORD (symbol, Lisp_Type_Symbol, struct Lisp_Symbol); -#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Type_Symbol, struct Lisp_Symbol) +DECLARE_NONRECORD (symbol, Lisp_Type_Symbol, Lisp_Symbol); +#define XSYMBOL(x) XNONRECORD (x, symbol, Lisp_Type_Symbol, Lisp_Symbol) #define XSETSYMBOL(s, p) XSETOBJ ((s), Lisp_Type_Symbol, (p)) #define SYMBOLP(x) (XTYPE (x) == Lisp_Type_Symbol) #define GC_SYMBOLP(x) (XGCTYPE (x) == Lisp_Type_Symbol) @@ -1076,9 +1319,10 @@ CONST char *name; lisp_fn_t subr_fn; }; - -DECLARE_LRECORD (subr, struct Lisp_Subr); -#define XSUBR(x) XRECORD (x, subr, struct Lisp_Subr) +typedef struct Lisp_Subr Lisp_Subr; + +DECLARE_LRECORD (subr, Lisp_Subr); +#define XSUBR(x) XRECORD (x, subr, Lisp_Subr) #define XSETSUBR(x, p) XSETRECORD (x, p, subr) #define SUBRP(x) RECORDP (x, subr) #define GC_SUBRP(x) GC_RECORDP (x, subr) @@ -1098,9 +1342,10 @@ Memind memind; char insertion_type; }; - -DECLARE_LRECORD (marker, struct Lisp_Marker); -#define XMARKER(x) XRECORD (x, marker, struct Lisp_Marker) +typedef struct Lisp_Marker Lisp_Marker; + +DECLARE_LRECORD (marker, Lisp_Marker); +#define XMARKER(x) XRECORD (x, marker, Lisp_Marker) #define XSETMARKER(x, p) XSETRECORD (x, p, marker) #define MARKERP(x) RECORDP (x, marker) #define GC_MARKERP(x) GC_RECORDP (x, marker) @@ -1142,7 +1387,7 @@ #ifdef LISP_FLOAT_TYPE -/* Note: the 'unused__next__' field exists only to ensure that the +/* Note: the 'unused_next_' field exists only to ensure that the `next' pointer fits within the structure, for the purposes of the free list. This makes a difference in the unlikely case of sizeof(double) being smaller than sizeof(void *). */ @@ -1150,11 +1395,12 @@ 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; }; - -DECLARE_LRECORD (float, struct Lisp_Float); -#define XFLOAT(x) XRECORD (x, float, struct Lisp_Float) +typedef struct Lisp_Float Lisp_Float; + +DECLARE_LRECORD (float, Lisp_Float); +#define XFLOAT(x) XRECORD (x, float, Lisp_Float) #define XSETFLOAT(x, p) XSETRECORD (x, p, float) #define FLOATP(x) RECORDP (x, float) #define GC_FLOATP(x) GC_RECORDP (x, float) @@ -1162,6 +1408,7 @@ #define CONCHECK_FLOAT(x) CONCHECK_RECORD (x, float) #define float_data(f) ((f)->data.d) +#define XFLOAT_DATA(x) float_data (XFLOAT (x)) #define XFLOATINT(n) extract_float (n) @@ -1175,29 +1422,6 @@ x = wrong_type_argument (Qnumberp, x); \ } while (0) -/* These are always continuable because they change their arguments - even when no error is signalled. */ - -#define CHECK_INT_OR_FLOAT_COERCE_MARKER(x) do { \ - if (INT_OR_FLOATP (x)) \ - ; \ - else if (MARKERP (x)) \ - x = make_int (marker_position (x)); \ - else \ - x = wrong_type_argument (Qnumber_or_marker_p, x); \ -} while (0) - -#define CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER(x) do { \ - if (INT_OR_FLOATP (x)) \ - ; \ - else if (CHARP (x)) \ - x = make_int (XCHAR (x)); \ - else if (MARKERP (x)) \ - x = make_int (marker_position (x)); \ - else \ - x = wrong_type_argument (Qnumber_char_or_marker_p, x); \ -} while (0) - # define INT_OR_FLOATP(x) (INTP (x) || FLOATP (x)) # define GC_INT_OR_FLOATP(x) (GC_INTP (x) || GC_FLOATP (x)) @@ -1213,9 +1437,6 @@ #define XFLOATINT(n) XINT(n) #define CHECK_INT_OR_FLOAT CHECK_INT #define CONCHECK_INT_OR_FLOAT CONCHECK_INT -#define CHECK_INT_OR_FLOAT_COERCE_MARKER CHECK_INT_COERCE_MARKER -#define CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER \ - CHECK_INT_COERCE_CHAR_OR_MARKER #define INT_OR_FLOATP(x) (INTP (x)) # define GC_INT_OR_FLOATP(x) (GC_INTP (x)) @@ -1306,6 +1527,7 @@ x = wrong_type_argument (Qinteger_char_or_marker_p, x); \ } while (0) + /*********** pure space ***********/ #define CHECK_IMPURE(obj) \ @@ -1419,7 +1641,7 @@ /************************************************************************/ -/* Definitions of primitive Lisp functions and variables */ +/* Definitions of primitive Lisp functions and variables */ /************************************************************************/ @@ -1430,8 +1652,8 @@ valid in a C identifier, with an "F" prepended. The name of the C constant structure that records information on this function for internal use is "S" concatenated with Fname. - `minargs' should be a number, the minimum number of arguments allowed. - `maxargs' should be a number, the maximum number of arguments allowed, + `min_args' should be a number, the minimum number of arguments allowed. + `max_args' should be a number, the maximum number of arguments allowed, or else MANY or UNEVALLED. MANY means pass a vector of evaluated arguments, in the form of an integer number-of-arguments @@ -1462,7 +1684,7 @@ Lisp_Object,Lisp_Object,Lisp_Object #define EXFUN_MANY int, Lisp_Object* #define EXFUN_UNEVALLED Lisp_Object -#define EXFUN(sym, maxargs) Lisp_Object sym (EXFUN_##maxargs) +#define EXFUN(sym, max_args) Lisp_Object sym (EXFUN_##max_args) #define SUBR_MAX_ARGS 8 #define MANY -2 @@ -1477,14 +1699,14 @@ # define subr_lheader_initializer { lrecord_subr } #endif -#define DEFUN(lname, Fname, minargs, maxargs, prompt, arglist) \ - Lisp_Object Fname (EXFUN_##maxargs); \ +#define DEFUN(lname, Fname, min_args, max_args, prompt, arglist) \ + Lisp_Object Fname (EXFUN_##max_args); \ static struct Lisp_Subr S##Fname = { subr_lheader_initializer, \ - minargs, maxargs, prompt, 0, lname, (lisp_fn_t) Fname }; \ - Lisp_Object Fname (DEFUN_##maxargs arglist) + min_args, max_args, prompt, 0, lname, (lisp_fn_t) Fname }; \ + Lisp_Object Fname (DEFUN_##max_args arglist) /* Heavy ANSI C preprocessor hackery to get DEFUN to declare a - prototype that matches maxargs, and add the obligatory + prototype that matches max_args, and add the obligatory `Lisp_Object' type declaration to the formal C arguments. */ #define DEFUN_MANY(named_int, named_Lisp_Object) named_int, named_Lisp_Object @@ -1499,18 +1721,27 @@ #define DEFUN_7(a,b,c,d,e,f,g) DEFUN_6(a,b,c,d,e,f), Lisp_Object g #define DEFUN_8(a,b,c,d,e,f,g,h) DEFUN_7(a,b,c,d,e,f,g),Lisp_Object h -/* WARNING: If you add defines here for higher values of maxargs, - make sure to also fix the clauses in inline_funcall_fn(), +/* WARNING: If you add defines here for higher values of max_args, + make sure to also fix the clauses in PRIMITIVE_FUNCALL(), and change the define of SUBR_MAX_ARGS above. */ #include "symeval.h" -/* Depth of special binding/unwind-protect stack. Use as arg to `unbind_to' */ -int specpdl_depth (void); +/* `specpdl' is the special binding/unwind-protect stack. + + Knuth says (see the Jargon File): + At MIT, `pdl' [abbreviation for `Push Down List'] used to + be a more common synonym for `stack'. + Everywhere else `stack' seems to be the preferred term. + + specpdl_depth is the current depth of `specpdl'. + Save this for use later as arg to `unbind_to'. */ +extern int specpdl_depth_counter; +#define specpdl_depth() specpdl_depth_counter /************************************************************************/ -/* Checking for QUIT */ +/* Checking for QUIT */ /************************************************************************/ /* Asynchronous events set something_happened, and then are processed @@ -1554,7 +1785,7 @@ /************************************************************************/ -/* hashing */ +/* hashing */ /************************************************************************/ /* #### for a 64-bit machine, we should substitute a prime just over 2^32 */ @@ -1568,8 +1799,6 @@ #define HASH8(a,b,c,d,e,f,g,h) (GOOD_HASH * HASH7 (a,b,c,d,e,f,g) + (h)) #define HASH9(a,b,c,d,e,f,g,h,i) (GOOD_HASH * HASH8 (a,b,c,d,e,f,g,h) + (i)) -/* Enough already! */ - #define LISP_HASH(obj) ((unsigned long) LISP_TO_VOID (obj)) unsigned long string_hash (CONST void *xv); unsigned long memory_hash (CONST void *xv, size_t size); @@ -1578,7 +1807,7 @@ /************************************************************************/ -/* String translation */ +/* String translation */ /************************************************************************/ #ifdef I18N3 @@ -1606,7 +1835,7 @@ /************************************************************************/ -/* Garbage collection / GC-protection */ +/* Garbage collection / GC-protection */ /************************************************************************/ /* number of bytes of structure consed since last GC */ @@ -1708,101 +1937,104 @@ #else /* ! DEBUG_GCPRO */ -#define GCPRO1(varname) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname; gcpro1.nvars = 1; \ - gcprolist = &gcpro1; } - -#define GCPRO2(varname1, varname2) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcprolist = &gcpro2; } - -#define GCPRO3(varname1, varname2, varname3) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \ - gcprolist = &gcpro3; } - -#define GCPRO4(varname1, varname2, varname3, varname4) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \ - gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \ - gcprolist = &gcpro4; } - -#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \ - {gcpro1.next = gcprolist; gcpro1.var = &varname1; gcpro1.nvars = 1; \ - gcpro2.next = &gcpro1; gcpro2.var = &varname2; gcpro2.nvars = 1; \ - gcpro3.next = &gcpro2; gcpro3.var = &varname3; gcpro3.nvars = 1; \ - gcpro4.next = &gcpro3; gcpro4.var = &varname4; gcpro4.nvars = 1; \ - gcpro5.next = &gcpro4; gcpro5.var = &varname5; gcpro5.nvars = 1; \ - gcprolist = &gcpro5; } - -#define UNGCPRO (gcprolist = gcpro1.next) - -#define NGCPRO1(varname) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname; ngcpro1.nvars = 1; \ - gcprolist = &ngcpro1; } - -#define NGCPRO2(varname1, varname2) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - gcprolist = &ngcpro2; } - -#define NGCPRO3(varname1, varname2, varname3) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \ - gcprolist = &ngcpro3; } - -#define NGCPRO4(varname1, varname2, varname3, varname4) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \ - ngcpro4.next = &ngcpro3; ngcpro4.var = &varname4; ngcpro4.nvars = 1; \ - gcprolist = &ngcpro4; } - -#define NGCPRO5(varname1, varname2, varname3, varname4, varname5) \ - {ngcpro1.next = gcprolist; ngcpro1.var = &varname1; ngcpro1.nvars = 1; \ - ngcpro2.next = &ngcpro1; ngcpro2.var = &varname2; ngcpro2.nvars = 1; \ - ngcpro3.next = &ngcpro2; ngcpro3.var = &varname3; ngcpro3.nvars = 1; \ - ngcpro4.next = &ngcpro3; ngcpro4.var = &varname4; ngcpro4.nvars = 1; \ - ngcpro5.next = &ngcpro4; ngcpro5.var = &varname5; ngcpro5.nvars = 1; \ - gcprolist = &ngcpro5; } - -#define NUNGCPRO (gcprolist = ngcpro1.next) - -#define NNGCPRO1(varname) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname; nngcpro1.nvars = 1; \ - gcprolist = &nngcpro1; } - -#define NNGCPRO2(varname1, varname2) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - gcprolist = &nngcpro2; } - -#define NNGCPRO3(varname1, varname2, varname3) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \ - gcprolist = &nngcpro3; } - -#define NNGCPRO4(varname1, varname2, varname3, varname4) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \ - nngcpro4.next = &nngcpro3; nngcpro4.var = &varname4; nngcpro4.nvars = 1; \ - gcprolist = &nngcpro4; } - -#define NNGCPRO5(varname1, varname2, varname3, varname4, varname5) \ - {nngcpro1.next = gcprolist; nngcpro1.var = &varname1; nngcpro1.nvars = 1; \ - nngcpro2.next = &nngcpro1; nngcpro2.var = &varname2; nngcpro2.nvars = 1; \ - nngcpro3.next = &nngcpro2; nngcpro3.var = &varname3; nngcpro3.nvars = 1; \ - nngcpro4.next = &nngcpro3; nngcpro4.var = &varname4; nngcpro4.nvars = 1; \ - nngcpro5.next = &nngcpro4; nngcpro5.var = &varname5; nngcpro5.nvars = 1; \ - gcprolist = &nngcpro5; } - -#define NNUNGCPRO (gcprolist = nngcpro1.next) +#define GCPRO1(var1) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcprolist = &gcpro1 )) + +#define GCPRO2(var1, var2) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcprolist = &gcpro2 )) + +#define GCPRO3(var1, var2, var3) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \ + gcprolist = &gcpro3 )) + +#define GCPRO4(var1, var2, var3, var4) ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \ + gcpro4.next = &gcpro3, gcpro4.var = &var4, gcpro4.nvars = 1, \ + gcprolist = &gcpro4 )) + +#define GCPRO5(var1, var2, var3, var4, var5) \ + ((void) ( \ + gcpro1.next = gcprolist, gcpro1.var = &var1, gcpro1.nvars = 1, \ + gcpro2.next = &gcpro1, gcpro2.var = &var2, gcpro2.nvars = 1, \ + gcpro3.next = &gcpro2, gcpro3.var = &var3, gcpro3.nvars = 1, \ + gcpro4.next = &gcpro3, gcpro4.var = &var4, gcpro4.nvars = 1, \ + gcpro5.next = &gcpro4, gcpro5.var = &var5, gcpro5.nvars = 1, \ + gcprolist = &gcpro5 )) + +#define UNGCPRO ((void) (gcprolist = gcpro1.next)) + +#define NGCPRO1(var1) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + gcprolist = &ngcpro1 )) + +#define NGCPRO2(var1, var2) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + gcprolist = &ngcpro2 )) + +#define NGCPRO3(var1, var2, var3) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \ + gcprolist = &ngcpro3 )) + +#define NGCPRO4(var1, var2, var3, var4) ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \ + ngcpro4.next = &ngcpro3, ngcpro4.var = &var4, ngcpro4.nvars = 1, \ + gcprolist = &ngcpro4 )) + +#define NGCPRO5(var1, var2, var3, var4, var5) \ + ((void) ( \ + ngcpro1.next = gcprolist, ngcpro1.var = &var1, ngcpro1.nvars = 1, \ + ngcpro2.next = &ngcpro1, ngcpro2.var = &var2, ngcpro2.nvars = 1, \ + ngcpro3.next = &ngcpro2, ngcpro3.var = &var3, ngcpro3.nvars = 1, \ + ngcpro4.next = &ngcpro3, ngcpro4.var = &var4, ngcpro4.nvars = 1, \ + ngcpro5.next = &ngcpro4, ngcpro5.var = &var5, ngcpro5.nvars = 1, \ + gcprolist = &ngcpro5 )) + +#define NUNGCPRO ((void) (gcprolist = ngcpro1.next)) + +#define NNGCPRO1(var1) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + gcprolist = &nngcpro1 )) + +#define NNGCPRO2(var1, var2) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + gcprolist = &nngcpro2 )) + +#define NNGCPRO3(var1, var2, var3) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \ + gcprolist = &nngcpro3 )) + +#define NNGCPRO4(var1, var2, var3, var4) ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \ + nngcpro4.next = &nngcpro3, nngcpro4.var = &var4, nngcpro4.nvars = 1, \ + gcprolist = &nngcpro4 )) + +#define NNGCPRO5(var1, var2, var3, var4, var5) \ + ((void) ( \ + nngcpro1.next = gcprolist, nngcpro1.var = &var1, nngcpro1.nvars = 1, \ + nngcpro2.next = &nngcpro1, nngcpro2.var = &var2, nngcpro2.nvars = 1, \ + nngcpro3.next = &nngcpro2, nngcpro3.var = &var3, nngcpro3.nvars = 1, \ + nngcpro4.next = &nngcpro3, nngcpro4.var = &var4, nngcpro4.nvars = 1, \ + nngcpro5.next = &nngcpro4, nngcpro5.var = &var5, nngcpro5.nvars = 1, \ + gcprolist = &nngcpro5 )) + +#define NNUNGCPRO ((void) (gcprolist = nngcpro1.next)) #endif /* ! DEBUG_GCPRO */ @@ -1810,10 +2042,10 @@ /* "end-of-loop code not reached" */ /* "statement not reached */ #ifdef __SUNPRO_C -#define RETURN__ if (1) return +#define RETURN_SANS_WARNINGS if (1) return #define RETURN_NOT_REACHED(value) #else -#define RETURN__ return +#define RETURN_SANS_WARNINGS return #define RETURN_NOT_REACHED(value) return value; #endif @@ -1822,7 +2054,7 @@ { \ Lisp_Object ret_ungc_val = (expr); \ UNGCPRO; \ - RETURN__ ret_ungc_val; \ + RETURN_SANS_WARNINGS ret_ungc_val; \ } while (0) /* Evaluate expr, NUNGCPRO, UNGCPRO, and then return the value of expr. */ @@ -1831,7 +2063,7 @@ Lisp_Object ret_ungc_val = (expr); \ NUNGCPRO; \ UNGCPRO; \ - RETURN__ ret_ungc_val; \ + RETURN_SANS_WARNINGS ret_ungc_val; \ } while (0) /* Evaluate expr, NNUNGCPRO, NUNGCPRO, UNGCPRO, and then return the @@ -1842,7 +2074,7 @@ NNUNGCPRO; \ NUNGCPRO; \ UNGCPRO; \ - RETURN__ ret_ungc_val; \ + RETURN_SANS_WARNINGS ret_ungc_val; \ } while (0) /* Evaluate expr, return it if it's not Qunbound. */ @@ -1850,7 +2082,7 @@ { \ Lisp_Object ret_nunb_val = (expr); \ if (!UNBOUNDP (ret_nunb_val)) \ - RETURN__ ret_nunb_val; \ + RETURN_SANS_WARNINGS ret_nunb_val; \ } while (0) /* Call staticpro (&var) to protect static variable `var'. */ @@ -1895,17 +2127,17 @@ #define DIRECTORY_SEP '/' #endif #ifndef IS_DIRECTORY_SEP -#define IS_DIRECTORY_SEP(_c_) ((_c_) == DIRECTORY_SEP) +#define IS_DIRECTORY_SEP(c) ((c) == DIRECTORY_SEP) #endif #ifndef IS_DEVICE_SEP #ifndef DEVICE_SEP -#define IS_DEVICE_SEP(_c_) 0 +#define IS_DEVICE_SEP(c) 0 #else -#define IS_DEVICE_SEP(_c_) ((_c_) == DEVICE_SEP) +#define IS_DEVICE_SEP(c) ((c) == DEVICE_SEP) #endif #endif #ifndef IS_ANY_SEP -#define IS_ANY_SEP(_c_) (IS_DIRECTORY_SEP (_c_)) +#define IS_ANY_SEP(c) (IS_DIRECTORY_SEP (c)) #endif #ifdef HAVE_INTTYPES_H @@ -1968,11 +2200,11 @@ Lisp_Object pure_cons (Lisp_Object, Lisp_Object); Lisp_Object pure_list (int, Lisp_Object *); Lisp_Object make_pure_vector (size_t, Lisp_Object); -void free_cons (struct Lisp_Cons *); +void free_cons (Lisp_Cons *); void free_list (Lisp_Object); void free_alist (Lisp_Object); void mark_conses_in_list (Lisp_Object); -void free_marker (struct Lisp_Marker *); +void free_marker (Lisp_Marker *); int object_dead_p (Lisp_Object); #ifdef MEMORY_USAGE_STATS @@ -2058,7 +2290,7 @@ Lisp_Object save_current_buffer_restore (Lisp_Object); /* Defined in emacs.c */ -DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (fatal (CONST char *, +DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (fatal (CONST char *, ...), 1, 2); int stderr_out (CONST char *, ...) PRINTF_ARGS (1, 2); int stdout_out (CONST char *, ...) PRINTF_ARGS (1, 2); @@ -2080,7 +2312,7 @@ void maybe_signal_error (Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior); Lisp_Object maybe_signal_continuable_error (Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior); -DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (error (CONST char *, +DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (error (CONST char *, ...), 1, 2); void maybe_error (Lisp_Object, Error_behavior, CONST char *, ...) PRINTF_ARGS (3, 4); @@ -2093,7 +2325,7 @@ Lisp_Object signal_simple_continuable_error (CONST char *, Lisp_Object); Lisp_Object maybe_signal_simple_continuable_error (CONST char *, Lisp_Object, Lisp_Object, Error_behavior); -DECLARE_DOESNT_RETURN_GCC__ATTRIBUTE__SYNTAX_SUCKS (error_with_frob +DECLARE_DOESNT_RETURN_GCC_ATTRIBUTE_SYNTAX_SUCKS (error_with_frob (Lisp_Object, CONST char *, ...), 2, 3); void maybe_error_with_frob (Lisp_Object, Lisp_Object, Error_behavior, @@ -2111,7 +2343,11 @@ Lisp_Object maybe_signal_simple_continuable_error_2 (CONST char *, Lisp_Object, Lisp_Object, Lisp_Object, Error_behavior); -Lisp_Object funcall_recording_as (Lisp_Object, int, Lisp_Object *); +void signal_malformed_list_error (Lisp_Object); +void signal_malformed_property_list_error (Lisp_Object); +void signal_circular_list_error (Lisp_Object); +void signal_circular_property_list_error (Lisp_Object); +void signal_void_function_error (Lisp_Object); Lisp_Object run_hook_with_args_in_buffer (struct buffer *, int, Lisp_Object *, enum run_hooks_condition); Lisp_Object run_hook_with_args (int, Lisp_Object *, enum run_hooks_condition); @@ -2195,7 +2431,7 @@ /* Defined in events.c */ void clear_event_resource (void); Lisp_Object allocate_event (void); -int event_to_character (struct Lisp_Event *, int, int, int); +int event_to_character (Lisp_Event *, int, int, int); /* Defined in fileio.c */ void record_auto_save (void); @@ -2265,6 +2501,7 @@ Lisp_Object vconcat2 (Lisp_Object, Lisp_Object); Lisp_Object vconcat3 (Lisp_Object, Lisp_Object, Lisp_Object); Lisp_Object nconc2 (Lisp_Object, Lisp_Object); +Lisp_Object bytecode_nconc2 (Lisp_Object *); void check_losing_bytecode (CONST char *, Lisp_Object); /* Defined in getloadavg.c */ @@ -2354,7 +2591,7 @@ enum external_data_format); void debug_print (Lisp_Object); void debug_short_backtrace (int); -void temp_output_buffer_setup (CONST char *); +void temp_output_buffer_setup (Lisp_Object); void temp_output_buffer_show (Lisp_Object, Lisp_Object); /* NOTE: Do not call this with the data of a Lisp_String. Use princ. * Note: stream should be defaulted before calling @@ -2369,10 +2606,9 @@ void print_internal (Lisp_Object, Lisp_Object, int); void print_symbol (Lisp_Object, Lisp_Object, int); void print_float (Lisp_Object, Lisp_Object, int); -void print_compiled_function (Lisp_Object, Lisp_Object, int); extern int print_escape_newlines; extern int print_readably; -Lisp_Object internal_with_output_to_temp_buffer (CONST char *, +Lisp_Object internal_with_output_to_temp_buffer (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object); void float_to_string (char *, double); @@ -2437,6 +2673,9 @@ Lisp_Object find_symbol_value (Lisp_Object); Lisp_Object find_symbol_value_quickly (Lisp_Object, int); Lisp_Object top_level_value (Lisp_Object); +void reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, + int function_p, + Lisp_Object follow_past_lisp_magic); /* Defined in syntax.c */ int scan_words (struct buffer *, int, int); @@ -2492,7 +2731,6 @@ EXFUN (Fchar_to_string, 1); EXFUN (Fcheck_valid_plist, 1); EXFUN (Fclear_range_table, 1); -EXFUN (Fclrhash, 1); EXFUN (Fcoding_category_list, 0); EXFUN (Fcoding_category_system, 1); EXFUN (Fcoding_priority_list, 0); @@ -2505,12 +2743,12 @@ EXFUN (Fcoding_system_type, 1); EXFUN (Fcommand_execute, 3); EXFUN (Fcommandp, 1); -EXFUN (Fcompiled_function_domain, 1); EXFUN (Fconcat, MANY); EXFUN (Fcons, 2); EXFUN (Fcopy_alist, 1); EXFUN (Fcopy_coding_system, 2); EXFUN (Fcopy_event, 2); +EXFUN (Fcopy_list, 1); EXFUN (Fcopy_marker, 2); EXFUN (Fcopy_sequence, 1); EXFUN (Fcopy_tree, 2); @@ -2577,11 +2815,9 @@ EXFUN (Fget_coding_system, 1); EXFUN (Fget_process, 1); EXFUN (Fget_range_table, 3); -EXFUN (Fgethash, 3); EXFUN (Fgettext, 1); EXFUN (Fgoto_char, 2); EXFUN (Fgtr, MANY); -EXFUN (Fhashtablep, 1); EXFUN (Findent_to, 3); EXFUN (Findirect_function, 1); EXFUN (Finsert, MANY); @@ -2604,7 +2840,6 @@ EXFUN (Fmake_byte_code, MANY); EXFUN (Fmake_coding_system, 4); EXFUN (Fmake_glyph_internal, 1); -EXFUN (Fmake_hashtable, 2); EXFUN (Fmake_list, 2); EXFUN (Fmake_marker, 0); EXFUN (Fmake_range_table, 0); @@ -2652,7 +2887,6 @@ EXFUN (Fput, 3); EXFUN (Fput_range_table, 4); EXFUN (Fput_text_property, 5); -EXFUN (Fputhash, 3); EXFUN (Fquo, MANY); EXFUN (Frassq, 2); EXFUN (Fread, 1); @@ -2720,8 +2954,9 @@ extern Lisp_Object Qcategory_designator_p, Qcategory_table_value_p, Qccl, Qcdr; extern Lisp_Object Qchannel, Qchar, Qchar_or_string_p, Qcharacter, Qcharacterp; extern Lisp_Object Qchars, Qcharset_g0, Qcharset_g1, Qcharset_g2, Qcharset_g3; -extern Lisp_Object Qcircular_property_list, Qcoding_system_error; -extern Lisp_Object Qcoding_system_p, Qcolor, Qcolor_pixmap_image_instance_p; +extern Lisp_Object Qcircular_list, Qcircular_property_list; +extern Lisp_Object Qcoding_system_error, Qcoding_system_p; +extern Lisp_Object Qcolor, Qcolor_pixmap_image_instance_p; extern Lisp_Object Qcolumns, Qcommand, Qcommandp, Qcompletion_ignore_case; extern Lisp_Object Qconsole, Qconsole_live_p, Qconst_specifier, Qcr, Qcritical; extern Lisp_Object Qcrlf, Qctext, Qcurrent_menubar, Qcursor; @@ -2746,11 +2981,12 @@ extern Lisp_Object Qinvalid_function, Qinvalid_read_syntax, Qio_error; extern Lisp_Object Qiso2022, Qkey, Qkey_assoc, Qkeymap, Qlambda, Qleft, Qlf; extern Lisp_Object Qlist, Qlistp, Qload, Qlock_shift, Qmacro, Qmagic; -extern Lisp_Object Qmalformed_property_list, Qmalloc_overhead, Qmark, Qmarkers; +extern Lisp_Object Qmalformed_list, Qmalformed_property_list; +extern Lisp_Object Qmalloc_overhead, Qmark, Qmarkers; extern Lisp_Object Qmax, Qmemory, Qmessage, Qminus, Qmnemonic, Qmodifiers; extern Lisp_Object Qmono_pixmap_image_instance_p, Qmotion; extern Lisp_Object Qmouse_leave_buffer_hook, Qmswindows, Qname, Qnas, Qnatnump; -extern Lisp_Object Qnil, Qno_ascii_cntl, Qno_ascii_eol, Qno_catch; +extern Lisp_Object Qno_ascii_cntl, Qno_ascii_eol, Qno_catch; extern Lisp_Object Qno_conversion, Qno_iso6429, Qnone, Qnot, Qnothing; extern Lisp_Object Qnothing_image_instance_p, Qnotice; extern Lisp_Object Qnumber_char_or_marker_p, Qnumber_or_marker_p, Qnumberp; @@ -2785,7 +3021,7 @@ extern Lisp_Object Vbinary_process_output, Vblank_menubar; extern Lisp_Object Vcharset_ascii, Vcharset_composite, Vcharset_control_1; extern Lisp_Object Vcoding_system_for_read, Vcoding_system_for_write; -extern Lisp_Object Vcoding_system_hashtable, Vcommand_history; +extern Lisp_Object Vcoding_system_hash_table, Vcommand_history; extern Lisp_Object Vcommand_line_args, Vconfigure_info_directory; extern Lisp_Object Vconsole_list, Vcontrolling_terminal; extern Lisp_Object Vcurrent_compiled_function_annotation, Vcurrent_load_list; @@ -2815,5 +3051,6 @@ extern Lisp_Object Vwin32_generate_fake_inodes, Vwin32_pipe_read_delay; extern Lisp_Object Vx_initial_argv_list; +extern Lisp_Object Qmakunbound, Qset; #endif /* _XEMACS_LISP_H_ */ diff -r 76b7d63099ad -r 8626e4521993 src/lread.c --- a/src/lread.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/lread.c Mon Aug 13 11:07:10 2007 +0200 @@ -29,11 +29,9 @@ #include "buffer.h" #include "bytecode.h" -#include "commands.h" -#include "insdel.h" +#include "elhash.h" #include "lstream.h" #include "opaque.h" -#include #ifdef FILE_CODING #include "file-coding.h" #endif @@ -401,22 +399,18 @@ something to `funcall', but who would really do that? As they say in law, we've made a "good-faith effort" to unfuckify ourselves. And doing it this way avoids screwing - up args to `make-hashtable' and such. As it is, we have to + up args to `make-hash-table' and such. As it is, we have to add an extra Ebola check in decode_weak_list_type(). --ben */ - if (EQ (el, Qassoc)) - el = Qold_assoc; - if (EQ (el, Qdelq)) - el = Qold_delq; + if (EQ (el, Qassoc)) el = Qold_assoc; + else if (EQ (el, Qdelq)) el = Qold_delq; #if 0 /* I think this is a bad idea because it will probably mess with keymap code. */ - if (EQ (el, Qdelete)) - el = Qold_delete; + else if (EQ (el, Qdelete)) el = Qold_delete; #endif - if (EQ (el, Qrassq)) - el = Qold_rassq; - if (EQ (el, Qrassoc)) - el = Qold_rassoc; + else if (EQ (el, Qrassq)) el = Qold_rassq; + else if (EQ (el, Qrassoc)) el = Qold_rassoc; + XVECTOR_DATA (vector)[i] = el; } } @@ -470,11 +464,11 @@ Lisp_Object doc; assert (COMPILED_FUNCTIONP (john)); - if (CONSP (XCOMPILED_FUNCTION (john)->bytecodes)) + if (CONSP (XCOMPILED_FUNCTION (john)->instructions)) { struct gcpro ngcpro1; Lisp_Object juan = (pas_de_lache_ici - (fd, XCOMPILED_FUNCTION (john)->bytecodes)); + (fd, XCOMPILED_FUNCTION (john)->instructions)); Lisp_Object ivan; NGCPRO1 (juan); @@ -482,7 +476,7 @@ if (!CONSP (ivan)) signal_simple_error ("invalid lazy-loaded byte code", ivan); /* Remember to purecopy; see above. */ - XCOMPILED_FUNCTION (john)->bytecodes = Fpurecopy (XCAR (ivan)); + XCOMPILED_FUNCTION (john)->instructions = Fpurecopy (XCAR (ivan)); /* v18 or v19 bytecode file. Need to Ebolify. */ if (XCOMPILED_FUNCTION (john)->flags.ebolified && VECTORP (XCDR (ivan))) @@ -793,7 +787,7 @@ if (purify_flag && noninteractive) { if (EQ (last_file_loaded, file)) - message_append (" (%ld)", + message_append (" (%ld)", (unsigned long) (purespace_usage() - pure_usage)); else message ("Loading %s ...done (%ld)", XSTRING_DATA (file), @@ -848,10 +842,11 @@ if (!NILP (mode)) CHECK_NATNUM (mode); - locate_file (path_list, filename, - ((NILP (suffixes)) ? "" : - (char *) (XSTRING_DATA (suffixes))), - &tp, (NILP (mode) ? R_OK : XINT (mode))); + locate_file (path_list, + filename, + NILP (suffixes) ? "" : (char *) XSTRING_DATA (suffixes), + &tp, + NILP (mode) ? R_OK : XINT (mode)); return tp; } @@ -860,8 +855,7 @@ static Lisp_Object locate_file_refresh_hashing (Lisp_Object str) { - Lisp_Object hash = - make_directory_hash_table ((char *) XSTRING_DATA (str)); + Lisp_Object hash = make_directory_hash_table ((char *) XSTRING_DATA (str)); Fput (str, Qlocate_file_hash_table, hash); return hash; } @@ -872,7 +866,7 @@ locate_file_find_directory_hash_table (Lisp_Object str) { Lisp_Object hash = Fget (str, Qlocate_file_hash_table, Qnil); - if (NILP (Fhashtablep (hash))) + if (! HASH_TABLEP (hash)) return locate_file_refresh_hashing (str); return hash; } @@ -904,7 +898,7 @@ default-directory to be something non-absolute ... */ { if (NILP (filename)) - /* NIL means current dirctory */ + /* NIL means current directory */ filename = current_buffer->directory; else filename = Fexpand_file_name (filename, @@ -1119,7 +1113,7 @@ for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail)) { Lisp_Object pathel = Fcar (pathtail); - Lisp_Object hashtab; + Lisp_Object hash_table; Lisp_Object tail; int found; @@ -1138,13 +1132,13 @@ continue; } - hashtab = locate_file_find_directory_hash_table (pathel); + hash_table = locate_file_find_directory_hash_table (pathel); /* Loop over suffixes. */ for (tail = suffixtab, found = 0; !found && CONSP (tail); tail = XCDR (tail)) { - if (!NILP (Fgethash (XCAR (tail), hashtab, Qnil))) + if (!NILP (Fgethash (XCAR (tail), hash_table, Qnil))) found = 1; } @@ -1274,9 +1268,9 @@ { /* This function can GC */ REGISTER Emchar c; - REGISTER Lisp_Object val; + REGISTER Lisp_Object val = Qnil; int speccount = specpdl_depth (); - struct gcpro gcpro1; + struct gcpro gcpro1, gcpro2; struct buffer *b = 0; if (BUFFERP (readcharfun)) @@ -1293,7 +1287,7 @@ #ifdef COMPILED_FUNCTION_ANNOTATION_HACK Vcurrent_compiled_function_annotation = Qnil; #endif - GCPRO1 (sourcename); + GCPRO2 (val, sourcename); LOADHIST_ATTACH (sourcename); @@ -2401,11 +2395,11 @@ obj = read0(readcharfun); /* the call to `featurep' may GC. */ - GCPRO2(fexp, obj); - tem = call1(Qfeaturep, fexp); + GCPRO2 (fexp, obj); + tem = call1 (Qfeaturep, fexp); UNGCPRO; - if (c == '+' && NILP(tem)) goto retry; + if (c == '+' && NILP(tem)) goto retry; if (c == '-' && !NILP(tem)) goto retry; return obj; } @@ -2991,7 +2985,7 @@ Vvalues = Qnil; load_in_progress = 0; - + Vload_descriptor_list = Qnil; /* kludge: locate-file does not work for a null load-path, even if diff -r 76b7d63099ad -r 8626e4521993 src/lrecord.h --- a/src/lrecord.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/lrecord.h Mon Aug 13 11:07:10 2007 +0200 @@ -50,7 +50,7 @@ a `next' pointer, and are allocated using alloc_lcrecord(). Creating a new lcrecord type is fairly easy; just follow the - lead of some existing type (e.g. hashtables). Note that you + lead of some existing type (e.g. hash tables). Note that you do not need to supply all the methods (see below); reasonable defaults are provided for many of them. Alternatively, if you're just looking for a way of encapsulating data (which possibly @@ -89,11 +89,11 @@ */ #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION /* index into lrecord_implementations_table[] */ - unsigned type:8; + unsigned char type; /* 1 if the object is marked during GC, 0 otherwise. */ - unsigned mark:1; + char mark; /* 1 if the object resides in pure (read-only) space */ - unsigned pure:1; + char pure; #else CONST struct lrecord_implementation *implementation; #endif @@ -103,11 +103,11 @@ int lrecord_type_index (CONST struct lrecord_implementation *implementation); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION -# define set_lheader_implementation(header,imp) do \ -{ \ - (header)->type = lrecord_type_index (imp); \ - (header)->mark = 0; \ - (header)->pure = 0; \ +# define set_lheader_implementation(header,imp) do { \ + struct lrecord_header* SLI_header = (header); \ + (SLI_header)->type = lrecord_type_index (imp); \ + (SLI_header)->mark = 0; \ + (SLI_header)->pure = 0; \ } while (0) #else # define set_lheader_implementation(header,imp) \ @@ -117,27 +117,31 @@ 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. (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) */ + 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 object types allocate members + out of memory chunks, and are able to find all unmarked members + by sweeping through the elements of the list of chunks. */ struct lcrecord_header *next; - /* This is just for debugging/printing convenience. - Having this slot doesn't hurt us much spacewise, since an lcrecord - already has the above slots together with malloc overhead. */ + + /* The `uid' field is just for debugging/printing convenience. + Having this slot doesn't hurt us much spacewise, since an + lcrecord already has the above slots plus malloc overhead. */ unsigned int uid :31; - /* A flag that indicates whether this lcrecord is on a "free list". - Free lists are used to minimize the number of calls to malloc() - when we're repeatedly allocating and freeing a number of the - same sort of lcrecord. Lcrecords on a free list always get - marked in a different fashion, so we can use this flag as a - sanity check to make sure that free lists only have freed lcrecords - and there are no freed lcrecords elsewhere. */ + + /* The `free' field is a flag that indicates whether this lcrecord + is on a "free list". Free lists are used to minimize the number + of calls to malloc() when we're repeatedly allocating and freeing + a number of the same sort of lcrecord. Lcrecords on a free list + always get marked in a different fashion, so we can use this flag + as a sanity check to make sure that free lists only have freed + lcrecords and there are no freed lcrecords elsewhere. */ unsigned int free :1; }; @@ -149,7 +153,7 @@ }; /* This as the value of lheader->implementation->finalizer - * means that this record is already marked */ + means that this record is already marked */ void this_marks_a_marked_record (void *, int); /* see alloc.c for an explanation */ @@ -232,24 +236,21 @@ #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION -# define MARKED_RECORD_HEADER_P(lheader) (lheader)->mark -# define MARK_RECORD_HEADER(lheader) (lheader)->mark = 1 -# define UNMARK_RECORD_HEADER(lheader) (lheader)->mark = 0 +# define MARKED_RECORD_HEADER_P(lheader) ((lheader)->mark) +# define MARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 1)) +# define UNMARK_RECORD_HEADER(lheader) ((void) ((lheader)->mark = 0)) #else /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */ # define MARKED_RECORD_HEADER_P(lheader) \ - (((lheader)->implementation->finalizer) == this_marks_a_marked_record) -# define MARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)++); } while (0) -# define UNMARK_RECORD_HEADER(lheader) \ - do { (((lheader)->implementation)--); } while (0) + ((lheader)->implementation->finalizer == this_marks_a_marked_record) +# define MARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)++)) +# define UNMARK_RECORD_HEADER(lheader) ((void) (((lheader)->implementation)--)) #endif /* ! USE_INDEXED_LRECORD_IMPLEMENTATION */ #define UNMARKABLE_RECORD_HEADER_P(lheader) \ - ((LHEADER_IMPLEMENTATION (lheader)->marker) \ - == this_one_is_unmarkable) + (LHEADER_IMPLEMENTATION (lheader)->marker == this_one_is_unmarkable) /* Declaring the following structures as const puts them in the text (read-only) segment, which makes debugging inconvenient @@ -325,25 +326,25 @@ # define DECLARE_LRECORD(c_name, structtype) \ extern CONST_IF_NOT_DEBUG struct lrecord_implementation \ lrecord_##c_name[]; \ -INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ +INLINE structtype *error_check_##c_name (Lisp_Object obj); \ INLINE structtype * \ -error_check_##c_name (Lisp_Object _obj) \ +error_check_##c_name (Lisp_Object obj) \ { \ - XUNMARK (_obj); \ - assert (RECORD_TYPEP (_obj, lrecord_##c_name) || \ - MARKED_RECORD_P (_obj)); \ - return (structtype *) XPNTR (_obj); \ + XUNMARK (obj); \ + assert (RECORD_TYPEP (obj, lrecord_##c_name) || \ + MARKED_RECORD_P (obj)); \ + return (structtype *) XPNTR (obj); \ } \ extern Lisp_Object Q##c_name##p # define DECLARE_NONRECORD(c_name, type_enum, structtype) \ -INLINE structtype *error_check_##c_name (Lisp_Object _obj); \ +INLINE structtype *error_check_##c_name (Lisp_Object obj); \ INLINE structtype * \ -error_check_##c_name (Lisp_Object _obj) \ +error_check_##c_name (Lisp_Object obj) \ { \ - XUNMARK (_obj); \ - assert (XGCTYPE (_obj) == type_enum); \ - return (structtype *) XPNTR (_obj); \ + XUNMARK (obj); \ + assert (XGCTYPE (obj) == type_enum); \ + return (structtype *) XPNTR (obj); \ } \ extern Lisp_Object Q##c_name##p diff -r 76b7d63099ad -r 8626e4521993 src/lstream.c --- a/src/lstream.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/lstream.c Mon Aug 13 11:07:10 2007 +0200 @@ -146,8 +146,8 @@ Lstream *lstr = XLSTREAM (obj); char buf[200]; - sprintf (buf, "#", - lstr->imp->name, lstr); + sprintf (buf, "#", + lstr->imp->name, (long) lstr); write_c_string (buf, printcharfun); } @@ -1617,8 +1617,8 @@ struct lisp_buffer_stream *str = LISP_BUFFER_STREAM_DATA (XLSTREAM (stream)); - (markobj) (str->start); - (markobj) (str->end); + markobj (str->start); + markobj (str->end); return str->buffer; } diff -r 76b7d63099ad -r 8626e4521993 src/make-src-depend --- a/src/make-src-depend Mon Aug 13 11:06:08 2007 +0200 +++ b/src/make-src-depend Mon Aug 13 11:07:10 2007 +0200 @@ -35,6 +35,7 @@ die $usage if @ARGV; ($srcdir = $0) =~ s@[^/]+$@@; +$srcdir = "." if $srcdir eq ""; chdir $srcdir or die "$srcdir: $!"; opendir SRCDIR, "." or die "$srcdir: $!"; diff -r 76b7d63099ad -r 8626e4521993 src/malloc.c --- a/src/malloc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/malloc.c Mon Aug 13 11:07:10 2007 +0200 @@ -184,7 +184,7 @@ #include #endif /* BSD4_2 */ -#ifdef __STDC_ +#ifdef __STDC__ #ifndef HPUX /* not sure where this for NetBSD should really go and it probably applies to other systems */ diff -r 76b7d63099ad -r 8626e4521993 src/marker.c --- a/src/marker.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/marker.c Mon Aug 13 11:07:10 2007 +0200 @@ -75,16 +75,15 @@ } static int -marker_equal (Lisp_Object o1, Lisp_Object o2, int depth) +marker_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct buffer *b1 = XMARKER (o1)->buffer; - if (b1 != XMARKER (o2)->buffer) - return (0); - else if (!b1) - /* All markers pointing nowhere are equal */ - return (1); - else - return ((XMARKER (o1)->memind == XMARKER (o2)->memind)); + struct Lisp_Marker *marker1 = XMARKER (obj1); + struct Lisp_Marker *marker2 = XMARKER (obj2); + + return ((marker1->buffer == marker2->buffer) && + (marker1->memind == marker2->memind || + /* All markers pointing nowhere are equal */ + !marker1->buffer)); } static unsigned long @@ -180,7 +179,7 @@ (MARKERP (pos) && !XMARKER (pos)->buffer)) { if (point_p) - signal_simple_error ("can't make point-marker point nowhere", + signal_simple_error ("Can't make point-marker point nowhere", marker); if (XMARKER (marker)->buffer) unchain_marker (marker); @@ -199,7 +198,7 @@ { if (point_p) signal_simple_error - ("can't move point-marker in a killed buffer", marker); + ("Can't move point-marker in a killed buffer", marker); if (XMARKER (marker)->buffer) unchain_marker (marker); return marker; @@ -237,7 +236,7 @@ if (m->buffer != b) { if (point_p) - signal_simple_error ("can't change buffer of point-marker", marker); + signal_simple_error ("Can't change buffer of point-marker", marker); if (m->buffer != 0) unchain_marker (marker); m->buffer = b; diff -r 76b7d63099ad -r 8626e4521993 src/md5.c --- a/src/md5.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/md5.c Mon Aug 13 11:07:10 2007 +0200 @@ -27,10 +27,7 @@ #endif #include - -#include #include - #include #if defined HAVE_LIMITS_H || _LIBC diff -r 76b7d63099ad -r 8626e4521993 src/menubar-msw.c --- a/src/menubar-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/menubar-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -22,12 +22,12 @@ /* Synched up with: Not in FSF. */ -/* Autorship: +/* Author: Initially written by kkm 12/24/97, peeking into and copying stuff from menubar-x.c */ -/* Algotirhm for handling menus is as follows. When window's menubar +/* Algorithm for handling menus is as follows. When window's menubar * is created, current-menubar is not traversed in depth. Rather, only * top level items, both items and pulldowns, are added to the * menubar. Each pulldown is initially empty. When a pulldown is @@ -39,37 +39,37 @@ * descriptor list given menu handle. The key is an opaque ptr data * type, keeping menu handle, and the value is a list of strings * representing the path from the root of the menu to the item - * descriptor. Each frame has an associated hashtable. + * descriptor. Each frame has an associated hash table. * * Leaf items are assigned a unique id based on item's hash. When an * item is selected, Windows sends back the id. Unfortunately, only * low 16 bit of the ID are sent, and there's no way to get the 32-bit * value. Yes, Win32 is just a different set of bugs than X! Aside - * from this blame, another hasing mechanism is required to map menu + * from this blame, another hashing mechanism is required to map menu * ids to commands (which are actually Lisp_Object's). This mapping is - * performed in the same hashtable, as the lifetime of both maps is - * exactly the same. This is unabmigous, as menu handles are + * performed in the same hash table, as the lifetime of both maps is + * exactly the same. This is unambigous, as menu handles are * represented by lisp opaques, while command ids are by lisp * integers. The additional advantage for this is that command forms * are automatically GC-protected, which is important because these * may be transient forms generated by :filter functions. * - * The hashtable is not allowed to grow too much; it is pruned + * The hash table is not allowed to grow too much; it is pruned * whenever this is safe to do. This is done by re-creating the menu * bar, and clearing and refilling the hash table from scratch. * - * Popup menus are handled identially to pulldowns. A static hash + * Popup menus are handled identically to pulldowns. A static hash * table is used for popup menus, and lookup is made not in * current-menubar but in a lisp form supplied to the `popup' * function. * * Another Windows weirdness is that there's no way to tell that a * popup has been dismissed without making selection. We need to know - * that to cleanup the popup menu hashtable, but this is not honestly + * that to cleanup the popup menu hash table, but this is not honestly * doable using *documented* sequence of messages. Sticking to * particular knowledge is bad because this may break in Windows NT * 5.0, or Windows 98, or other future version. Instead, I allow the - * hashtables to hang around, and not clear them, unless WM_COMMAND is + * hash tables to hang around, and not clear them, unless WM_COMMAND is * received. This is worthy some memory but more safe. Hacks welcome, * anyways! * @@ -101,8 +101,8 @@ /* Current menu (bar or popup) descriptor. gcpro'ed */ static Lisp_Object current_menudesc; -/* Current menubar or popup hashtable. gcpro'ed */ -static Lisp_Object current_hashtable; +/* Current menubar or popup hash table. gcpro'ed */ +static Lisp_Object current_hash_table; /* This is used to allocate unique ids to menu items. Items ids are in MENU_ITEM_ID_MIN to MENU_ITEM_ID_MAX. @@ -125,7 +125,7 @@ static char* displayable_menu_item (struct gui_item* pgui_item, int bar_p) { - /* We construct the name in a static buffer. That's fine, beause + /* We construct the name in a static buffer. That's fine, because menu items longer than 128 chars are probably programming errors, and better be caught than displayed! */ @@ -160,7 +160,7 @@ /* * Allocation tries a hash based on item's path and name first. This * almost guarantees that the same item will override its old value in - * the hashtable rather than abandon it. + * the hash table rather than abandon it. */ static Lisp_Object allocate_menu_item_id (Lisp_Object path, Lisp_Object name, Lisp_Object suffix) @@ -190,9 +190,9 @@ /* * The idea of checksumming is that we must hash minimal object - * which is neccessarily changes when the item changes. For separator + * which is necessarily changes when the item changes. For separator * this is a constant, for grey strings and submenus these are hashes - * of names, since sumbenus are unpopulated until opened so always + * of names, since submenus are unpopulated until opened so always * equal otherwise. For items, this is a full hash value of a callback, * because a callback may me a form which can be changed only somewhere * in depth. @@ -355,7 +355,7 @@ * This function is called from populate_menu and checksum_menu. * When called to populate, MENU is a menu handle, PATH is a * list of strings representing menu path from root to this submenu, - * DESCRIPTOR is a menu descriptor, HASH_TAB is a hashtable associated + * DESCRIPTOR is a menu descriptor, HASH_TAB is a hash table associated * with root menu, BAR_P indicates whether this called for a menubar or * a popup, and POPULATE_P is non-zero. Return value must be ignored. * When called to checksum, DESCRIPTOR has the same meaning, POPULATE_P @@ -376,7 +376,7 @@ GCPRO_GUI_ITEM (&gui_item); /* We are sometimes called with the menubar unchanged, and with changed - right flush. We have to update the menubar in ths case, + right flush. We have to update the menubar in this case, so account for the compliance setting in the hash value */ checksum = REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIHGT_FLUSH; @@ -404,7 +404,7 @@ { if (NILP (XCAR (item_desc))) { - /* Do not flush right menubar items when MS style compiant */ + /* Do not flush right menubar items when MS style compliant */ if (bar_p && !REPLACE_ME_WITH_GLOBAL_VARIABLE_WHICH_CONTROLS_RIHGT_FLUSH) flush_right = 1; if (!populate_p) @@ -426,7 +426,7 @@ /* Add the header to the popup, if told so. The same as in X - an insensitive item, and a separator (Seems to me, there were - two separators in X... In Windows this looks ugly, anywats. */ + two separators in X... In Windows this looks ugly, anyways. */ if (!bar_p && !deep_p && popup_menu_titles && !NILP(gui_item.name)) { CHECK_STRING (gui_item.name); @@ -467,7 +467,7 @@ if (NILP (desc) && menubar != NULL) { /* Menubar has gone */ - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil; SetMenu (FRAME_MSWINDOWS_HANDLE (f), NULL); DestroyMenu (menubar); DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f)); @@ -493,15 +493,16 @@ populate: /* Come with empty hash table */ - if (NILP (FRAME_MSWINDOWS_MENU_HASHTABLE(f))) - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Fmake_hashtable (make_int (50), Qequal); + if (NILP (FRAME_MSWINDOWS_MENU_HASH_TABLE(f))) + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); else - Fclrhash (FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); Fputhash (hmenu_to_lisp_object (menubar), Qnil, - FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); populate_menu (menubar, Qnil, desc, - FRAME_MSWINDOWS_MENU_HASHTABLE(f), 1); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f), 1); SetMenu (FRAME_MSWINDOWS_HANDLE (f), menubar); DrawMenuBar (FRAME_MSWINDOWS_HANDLE (f)); @@ -517,7 +518,7 @@ return; /* #### If a filter function has set desc to Qnil, this abort() - triggers. To resolve, we must prevent filters explicitely from + triggers. To resolve, we must prevent filters explicitly from mangling with the active menu. In apply_filter probably? Is copy-tree on the whole menu too expensive? */ if (NILP(desc)) @@ -527,25 +528,25 @@ /* We do the trick by removing all items and re-populating top level */ empty_menu (menubar, 0); - assert (HASHTABLEP (FRAME_MSWINDOWS_MENU_HASHTABLE(f))); - Fclrhash (FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + assert (HASH_TABLEP (FRAME_MSWINDOWS_MENU_HASH_TABLE(f))); + Fclrhash (FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); Fputhash (hmenu_to_lisp_object (menubar), Qnil, - FRAME_MSWINDOWS_MENU_HASHTABLE(f)); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f)); populate_menu (menubar, Qnil, desc, - FRAME_MSWINDOWS_MENU_HASHTABLE(f), 1); + FRAME_MSWINDOWS_MENU_HASH_TABLE(f), 1); } /* * This is called when cleanup is possible. It is better not to - * clean things up at all than do it too earaly! + * clean things up at all than do it too early! */ static void menu_cleanup (struct frame *f) { /* This function can GC */ current_menudesc = Qnil; - current_hashtable = Qnil; + current_hash_table = Qnil; prune_menubar (f); } @@ -563,7 +564,7 @@ struct gcpro gcpro1; /* Find which guy is going to explode */ - path = Fgethash (hmenu_to_lisp_object (menu), current_hashtable, Qunbound); + path = Fgethash (hmenu_to_lisp_object (menu), current_hash_table, Qunbound); assert (!UNBOUNDP (path)); #ifdef DEBUG_XEMACS /* Allow to continue in a debugger after assert - not so fatal */ @@ -580,7 +581,7 @@ /* Now, stuff it */ /* DESC may be generated by filter, so we have to gcpro it */ GCPRO1 (desc); - populate_menu (menu, path, desc, current_hashtable, 0); + populate_menu (menu, path, desc, current_hash_table, 0); UNGCPRO; return Qt; } @@ -603,8 +604,8 @@ update_frame_menubar_maybe (f); current_menudesc = current_frame_menubar (f); - current_hashtable = FRAME_MSWINDOWS_MENU_HASHTABLE(f); - assert (HASHTABLEP (current_hashtable)); + current_hash_table = FRAME_MSWINDOWS_MENU_HASH_TABLE(f); + assert (HASH_TABLEP (current_hash_table)); return Qt; } @@ -622,14 +623,14 @@ Lisp_Object data, fn, arg, frame; struct gcpro gcpro1; - data = Fgethash (make_int (id), current_hashtable, Qunbound); + data = Fgethash (make_int (id), current_hash_table, Qunbound); if (UNBOUNDP (data)) { menu_cleanup (f); return Qnil; } - /* Need to gcpro because the hashtable may get destroyed by + /* Need to gcpro because the hash table may get destroyed by menu_cleanup(), and will not gcpro the data any more */ GCPRO1 (data); menu_cleanup (f); @@ -703,7 +704,7 @@ static void mswindows_free_frame_menubars (struct frame* f) { - FRAME_MSWINDOWS_MENU_HASHTABLE(f) = Qnil; + FRAME_MSWINDOWS_MENU_HASH_TABLE(f) = Qnil; } static void @@ -749,9 +750,10 @@ CHECK_STRING (XCAR (menu_desc)); current_menudesc = menu_desc; - current_hashtable = Fmake_hashtable (make_int(10), Qequal); + current_hash_table = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); menu = create_empty_popup_menu(); - Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hashtable); + Fputhash (hmenu_to_lisp_object (menu), Qnil, current_hash_table); top_level_menu = menu; /* see comments in menubar-x.c */ @@ -797,8 +799,8 @@ vars_of_menubar_mswindows (void) { current_menudesc = Qnil; - current_hashtable = Qnil; + current_hash_table = Qnil; staticpro (¤t_menudesc); - staticpro (¤t_hashtable); + staticpro (¤t_hash_table); } diff -r 76b7d63099ad -r 8626e4521993 src/menubar-msw.h --- a/src/menubar-msw.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/menubar-msw.h Mon Aug 13 11:07:10 2007 +0200 @@ -22,7 +22,7 @@ /* Synched up with: Not in FSF. */ -/* Autorship: +/* Author: Initially written by kkm 12/24/97, */ diff -r 76b7d63099ad -r 8626e4521993 src/menubar-x.c --- a/src/menubar-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/menubar-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -27,9 +27,7 @@ #include "lisp.h" #include "console-x.h" -#include "EmacsManager.h" #include "EmacsFrame.h" -#include "EmacsShell.h" #include "gui-x.h" #include "buffer.h" @@ -164,7 +162,7 @@ Lisp_Object cascade = desc; desc = Fcdr (desc); if (NILP (desc)) - signal_simple_error ("keyword in menu lacks a value", + signal_simple_error ("Keyword in menu lacks a value", cascade); val = Fcar (desc); desc = Fcdr (desc); @@ -189,7 +187,7 @@ /* implement in 21.2 */ } else - signal_simple_error ("unknown menu cascade keyword", cascade); + signal_simple_error ("Unknown menu cascade keyword", cascade); } if ((!NILP (config_tag) @@ -202,7 +200,7 @@ if (active_spec) active_p = Feval (active_p); - + if (!NILP (hook_fn) && !NILP (active_p)) { #if defined LWLIB_MENUBARS_LUCID || defined LWLIB_MENUBARS_MOTIF @@ -255,14 +253,14 @@ /* Add a fake entry so the menus show up */ wv->contents = dummy = xmalloc_widget_value (); dummy->name = "(inactive)"; - dummy->accel = NULL; + dummy->accel = LISP_TO_VOID (Qnil); dummy->enabled = 0; dummy->selected = 0; dummy->value = NULL; dummy->type = BUTTON_TYPE; dummy->call_data = NULL; dummy->next = NULL; - + goto menu_item_done; } @@ -275,10 +273,10 @@ } else { - signal_simple_error ("menu name (first element) must be a string", + signal_simple_error ("Menu name (first element) must be a string", desc); } - + if (deep_p || menubar_root_p) { widget_value *next; @@ -289,7 +287,7 @@ { if (partition_seen) error ( - "more than one partition (nil) in menubar description"); + "More than one partition (nil) in menubar description"); partition_seen = 1; next = xmalloc_widget_value (); next->type = PUSHRIGHT_TYPE; @@ -314,7 +312,7 @@ else if (NILP (desc)) error ("nil may not appear in menu descriptions"); else - signal_simple_error ("unrecognized menu descriptor", desc); + signal_simple_error ("Unrecognized menu descriptor", desc); menu_item_done: @@ -615,7 +613,7 @@ } -/* Called from x_create_widgets() to create the inital menubar of a frame +/* Called from x_create_widgets() to create the initial menubar of a frame before it is mapped, so that the window is mapped with the menubar already there instead of us tacking it on later and thrashing the window after it is visible. */ @@ -684,7 +682,7 @@ XtSetArg (al [1], XtNy, &framey); XtGetValues (daddy, al, 2); btn->x_root = shellx + framex + btn->x; - btn->y_root = shelly + framey + btn->y;; + btn->y_root = shelly + framey + btn->y; btn->state = ButtonPressMask; /* all buttons pressed */ } else diff -r 76b7d63099ad -r 8626e4521993 src/menubar.c --- a/src/menubar.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/menubar.c Mon Aug 13 11:07:10 2007 +0200 @@ -109,7 +109,7 @@ /* First element may be menu name, although can be omitted. Let's think that if stuff begins with anything than a keyword - or a list (submenu), this is a menu name, expected to be a stirng */ + or a list (submenu), this is a menu name, expected to be a string */ if (!KEYWORDP (XCAR (desc)) && !CONSP (XCAR (desc))) { CHECK_STRING (XCAR (desc)); @@ -156,7 +156,7 @@ gui_item_init (&gui_item); GCPRO_GUI_ITEM (&gui_item); - + EXTERNAL_LIST_LOOP (path_entry, path) { /* Verify that DESC describes a menu, not single item */ @@ -507,7 +507,7 @@ :label
(unimplemented!) Like :suffix, but replaces label completely. (might be added in 21.2). - + For example: ("File" diff -r 76b7d63099ad -r 8626e4521993 src/minibuf.c --- a/src/minibuf.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/minibuf.c Mon Aug 13 11:07:10 2007 +0200 @@ -289,14 +289,14 @@ } -/* #### Maybe we should allow ALIST to be a hashtable. It is wrong +/* #### Maybe we should allow ALIST to be a hash table. It is wrong for the use of obarrays to be better-rewarded than the use of - hashtables. By better-rewarded I mean that you can pass an obarray + hash tables. By better-rewarded I mean that you can pass an obarray to all of the completion functions, whereas you can't do anything - like that with a hashtable. + like that with a hash table. To do so, there should probably be a - map_obarray_or_alist_or_hashtable function which would be used by + map_obarray_or_alist_or_hash_table function which would be used by both Ftry_completion and Fall_completions. But would the additional funcalls slow things down? */ diff -r 76b7d63099ad -r 8626e4521993 src/mule-canna.c --- a/src/mule-canna.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/mule-canna.c Mon Aug 13 11:07:10 2007 +0200 @@ -372,8 +372,8 @@ char servername[256]; CHECK_STRING (server); - strncpy (servername, XSTRING (server)->_data, XSTRING (server)->_size); - servername[XSTRING (server)->_size] = '\0'; + strncpy (servername, XSTRING_DATA (server), XSTRING_LENGTH (server)); + servername[XSTRING_LENGTH (server)] = '\0'; jrKanjiControl (0, KC_SETSERVERNAME, servername); } @@ -386,8 +386,8 @@ char rcname[256]; CHECK_STRING (rcfile); - strncpy (rcname, XSTRING (rcfile)->_data, XSTRING (rcfile)->_size); - rcname[XSTRING (rcfile)->_size] = '\0'; + strncpy (rcname, XSTRING_DATA (rcfile), XSTRING_LENGTH (rcfile)); + rcname[XSTRING_LENGTH (rcfile)] = '\0'; jrKanjiControl (0, KC_SETINITFILENAME, rcname); } @@ -414,7 +414,7 @@ if (res == -1) { - val = Fcons (make_string ((unsigned char*) jrKanjiError, + val = Fcons (make_string ((unsigned char*) jrKanjiError, strlen (jrKanjiError)), val); /* ¥¤¥Ë¥·¥ã¥é¥¤¥º¤Ç¼ºÇÔ¤·¤¿¾ì¹ç¡£ */ return Fcons (Qnil, val); @@ -490,10 +490,10 @@ ksv.buffer = (unsigned char *) buf; ksv.bytes_buffer = KEYTOSTRSIZE; #ifndef CANNA_MULE - ks.echoStr = XSTRING (str)->_data; - ks.length = XSTRING (str)->_size; + ks.echoStr = XSTRING_DATA (str); + ks.length = XSTRING_LENGTH (str); #else /* CANNA_MULE */ - m2c (XSTRING (str)->_data, XSTRING (str)->_size, cbuf); + m2c (XSTRING_DATA (str), XSTRING_LENGTH (str), cbuf); ks.echoStr = cbuf; ks.length = strlen (cbuf); #endif /* CANNA_MULE */ @@ -504,7 +504,7 @@ } DEFUN ("canna-set-width", Fcanna_set_width, 1, 1, 0, /* -Set status-line width information, which is used to display +Set status-line width information, which is used to display kanji candidates. */ (num)) @@ -564,11 +564,11 @@ CHECK_STRING (yomi); #ifndef CANNA_MULE - strncpy (buf, XSTRING (yomi)->_data, XSTRING (yomi)->_size); - ks.length = XSTRING (yomi)->_size; + strncpy (buf, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi)); + ks.length = XSTRING_LENGTH (yomi); buf[ks.length] = '\0'; #else /* CANNA_MULE */ - m2c (XSTRING (yomi)->_data, XSTRING (yomi)->_size, buf); + m2c (XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), buf); ks.length = strlen (buf); #endif /* CANNA_MULE */ @@ -581,13 +581,13 @@ CHECK_STRING (roma); #ifndef CANNA_MULE - strncpy (buf + XSTRING (yomi)->_size + 1, XSTRING (roma)->_data, - XSTRING (roma)->_size); - buf[XSTRING (yomi)->_size + 1 + XSTRING (roma)->_size] = '\0'; - ks.mode = (unsigned char *)(buf + XSTRING (yomi)->_size + 1); + strncpy (buf + XSTRING_LENGTH (yomi) + 1, XSTRING_DATA (roma), + XSTRING_LENGTH (roma)); + buf[XSTRING_LENGTH (yomi) + 1 + XSTRING_LENGTH (roma)] = '\0'; + ks.mode = (unsigned char *)(buf + XSTRING_LENGTH (yomi) + 1); #else /* CANNA_MULE */ ks.mode = (unsigned char *)(buf + ks.length + 1); - m2c (XSTRING (roma)->_data, XSTRING (roma)->_size, ks.mode); + m2c (XSTRING_DATA (roma), XSTRING_LENGTH (roma), ks.mode); #endif /* CANNA_MULE */ } @@ -643,10 +643,10 @@ CHECK_STRING (str); #ifndef CANNA_MULE - strncpy (buf, XSTRING (str)->_data, XSTRING (str)->_size); - buf[XSTRING (str)->_size] = '\0'; + strncpy (buf, XSTRING_DATA (str), XSTRING_LENGTH (str)); + buf[XSTRING_LENGTH (str)] = '\0'; #else /* CANNA_MULE */ - m2c (XSTRING (str)->_data, XSTRING (str)->_size, buf); + m2c (XSTRING_DATA (str), XSTRING_LENGTH (str), buf); #endif /* CANNA_MULE */ p = (unsigned char**) buf; n = jrKanjiControl (0, KC_PARSE, (char *) &p); @@ -730,12 +730,12 @@ return Qnil; } #ifndef CANNA_MULE - strncpy (yomibuf, XSTRING (yomi)->_data, XSTRING (yomi)->_size); - yomibuf[XSTRING (yomi)->_size] = '\0'; - nbun = RkBgnBun (IRCP_context, XSTRING (yomi)->_data, XSTRING (yomi)->_size, + strncpy (yomibuf, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi)); + yomibuf[XSTRING_LENGTH (yomi)] = '\0'; + nbun = RkBgnBun (IRCP_context, XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), (RK_XFER << RK_XFERBITS) | RK_KFER); #else /* CANNA_MULE */ - m2c (XSTRING (yomi)->_data, XSTRING (yomi)->_size, yomibuf); + m2c (XSTRING_DATA (yomi), XSTRING_LENGTH (yomi), yomibuf); nbun = RkBgnBun (IRCP_context, (char *) yomibuf, strlen (yomibuf), (RK_XFER << RK_XFERBITS) | RK_KFER); #endif /* CANNA_MULE */ @@ -814,7 +814,7 @@ CHECK_INT (bunsetsu); CHECK_INT (bunlen); - + nbun = XINT (bunsetsu); if (confirmContext () == 0) { @@ -1024,7 +1024,7 @@ { DEFVAR_LISP ("CANNA", &VCANNA); /* hir@nec, 1992.5.21 */ VCANNA = Qt; /* hir@nec, 1992.5.21 */ - + DEFSUBR (Fcanna_key_proc); DEFSUBR (Fcanna_initialize); DEFSUBR (Fcanna_finalize); @@ -1780,7 +1780,7 @@ c2mu (char *cp, int l, char *mp) { char ch, *ep = cp+l; - + while ((cp < ep) && (ch = *cp)) { if ((unsigned char) ch == ISO_CODE_SS2) @@ -1809,8 +1809,8 @@ static void m2c (unsigned char *mp, int l, unsigned char *cp) { - unsigned char ch, *ep = mp + l;; - + unsigned char ch, *ep = mp + l; + while ((mp < ep) && (ch = *mp++)) { switch (ch) @@ -1829,7 +1829,7 @@ *cp++ = ch; break; } - } + } *cp = 0; } @@ -1840,10 +1840,10 @@ mule_make_string (unsigned char *p, int l) { unsigned char cbuf[4096]; - + c2mu (p,l,cbuf); return (make_string (cbuf,strlen (cbuf))); -} +} /* return the MULE internal string length of EUC string */ /* Modified by sb to return a character count not byte count. */ @@ -1852,7 +1852,7 @@ { unsigned char ch, *cp = p; int len = 0; - + while ((cp < p + l) && (ch = *cp)) { if ((unsigned char) ch == ISO_CODE_SS2) @@ -1873,7 +1873,7 @@ else { len++; - cp++; + cp++; } } return (len); @@ -1885,7 +1885,7 @@ int *crev) { unsigned char *q = p; - + *clen = *cpos = *crev = 0; if (len == 0) return; while (q < p + pos) @@ -1899,7 +1899,7 @@ (*clen)++; (*crev)++; if (*q++ & 0x80) q++; - } + } while (q < p + len) { (*clen)++; diff -r 76b7d63099ad -r 8626e4521993 src/mule-ccl.c --- a/src/mule-ccl.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/mule-ccl.c Mon Aug 13 11:07:10 2007 +0200 @@ -844,7 +844,7 @@ case CCL_MOD: reg[rrr] = i % j; break; case CCL_AND: reg[rrr] = i & j; break; case CCL_OR: reg[rrr] = i | j; break; - case CCL_XOR: reg[rrr] = i ^ j;; break; + case CCL_XOR: reg[rrr] = i ^ j; break; case CCL_LSH: reg[rrr] = i << j; break; case CCL_RSH: reg[rrr] = i >> j; break; case CCL_LSH8: reg[rrr] = (i << 8) | j; break; diff -r 76b7d63099ad -r 8626e4521993 src/mule-charset.c --- a/src/mule-charset.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/mule-charset.c Mon Aug 13 11:07:10 2007 +0200 @@ -60,11 +60,11 @@ Lisp_Object Vcharset_korean_ksc5601; Lisp_Object Vcharset_composite; -/* Hashtables for composite chars. One maps string representing +/* Hash tables for composite chars. One maps string representing composed chars to their equivalent chars; one goes the other way. */ -Lisp_Object Vcomposite_char_char2string_hashtable; -Lisp_Object Vcomposite_char_string2char_hashtable; +Lisp_Object Vcomposite_char_char2string_hash_table; +Lisp_Object Vcomposite_char_string2char_hash_table; /* Table of charsets indexed by leading byte. */ Lisp_Object charset_by_leading_byte[128]; @@ -136,7 +136,7 @@ Lisp_Object Ql2r, Qr2l; -Lisp_Object Vcharset_hashtable; +Lisp_Object Vcharset_hash_table; static Bufbyte next_allocated_1_byte_leading_byte; static Bufbyte next_allocated_2_byte_leading_byte; @@ -280,7 +280,7 @@ if (f1 + FIELD1_TO_OFFICIAL_LEADING_BYTE == LEADING_BYTE_COMPOSITE) { if (UNBOUNDP (Fgethash (make_int (ch), - Vcomposite_char_char2string_hashtable, + Vcomposite_char_char2string_hash_table, Qunbound))) return 0; return 1; @@ -391,9 +391,9 @@ { struct Lisp_Charset *cs = XCHARSET (obj); - (markobj) (cs->doc_string); - (markobj) (cs->registry); - (markobj) (cs->ccl_program); + markobj (cs->doc_string); + markobj (cs->registry); + markobj (cs->ccl_program); return cs->name; } @@ -461,7 +461,7 @@ CHARSET_TYPE (cs) == CHARSET_TYPE_96) ? 1 : 2; CHARSET_CHARS (cs) = (CHARSET_TYPE (cs) == CHARSET_TYPE_94 || CHARSET_TYPE (cs) == CHARSET_TYPE_94X94) ? 94 : 96; - + if (final) { /* some charsets do not have final characters. This includes @@ -480,7 +480,7 @@ /* Some charsets are "faux" and don't have names or really exist at all except in the leading-byte table. */ if (!NILP (name)) - Fputhash (name, obj, Vcharset_hashtable); + Fputhash (name, obj, Vcharset_hash_table); return obj; } @@ -537,7 +537,7 @@ return charset_or_name; CHECK_SYMBOL (charset_or_name); - return Fgethash (charset_or_name, Vcharset_hashtable, Qnil); + return Fgethash (charset_or_name, Vcharset_hash_table, Qnil); } DEFUN ("get-charset", Fget_charset, 1, 1, 0, /* @@ -563,19 +563,15 @@ }; static int -add_charset_to_list_mapper (CONST void *hash_key, void *hash_contents, +add_charset_to_list_mapper (Lisp_Object key, Lisp_Object value, void *charset_list_closure) { /* This function can GC */ - Lisp_Object key, contents; - Lisp_Object *charset_list; struct charset_list_closure *chcl = (struct charset_list_closure*) charset_list_closure; - CVOID_TO_LISP (key, hash_key); - VOID_TO_LISP (contents, hash_contents); - charset_list = chcl->charset_list; + Lisp_Object *charset_list = chcl->charset_list; - *charset_list = Fcons (XCHARSET_NAME (contents), *charset_list); + *charset_list = Fcons (XCHARSET_NAME (value), *charset_list); return 0; } @@ -590,7 +586,7 @@ GCPRO1 (charset_list); charset_list_closure.charset_list = &charset_list; - elisp_maphash (add_charset_to_list_mapper, Vcharset_hashtable, + elisp_maphash (add_charset_to_list_mapper, Vcharset_hash_table, &charset_list_closure); UNGCPRO; @@ -966,13 +962,13 @@ invalidate_charset_font_caches (Lisp_Object charset) { /* Invalidate font cache entries for charset on all devices. */ - Lisp_Object devcons, concons, hashtab; + Lisp_Object devcons, concons, hash_table; DEVICE_LOOP_NO_BREAK (devcons, concons) { struct device *d = XDEVICE (XCAR (devcons)); - hashtab = Fgethash (charset, d->charset_font_cache, Qunbound); - if (!UNBOUNDP (hashtab)) - Fclrhash (hashtab); + hash_table = Fgethash (charset, d->charset_font_cache, Qunbound); + if (!UNBOUNDP (hash_table)) + Fclrhash (hash_table); } } @@ -1077,7 +1073,7 @@ { Lisp_Object lispstr = make_string (str, len); Lisp_Object ch = Fgethash (lispstr, - Vcomposite_char_string2char_hashtable, + Vcomposite_char_string2char_hash_table, Qunbound); Emchar emch; @@ -1088,9 +1084,9 @@ emch = MAKE_CHAR (Vcharset_composite, composite_char_row_next, composite_char_col_next); Fputhash (make_char (emch), lispstr, - Vcomposite_char_char2string_hashtable); + Vcomposite_char_char2string_hash_table); Fputhash (lispstr, make_char (emch), - Vcomposite_char_string2char_hashtable); + Vcomposite_char_string2char_hash_table); composite_char_col_next++; if (composite_char_col_next >= 128) { @@ -1107,7 +1103,7 @@ composite_char_string (Emchar ch) { Lisp_Object str = Fgethash (make_char (ch), - Vcomposite_char_char2string_hashtable, + Vcomposite_char_char2string_hash_table, Qunbound); assert (!UNBOUNDP (str)); return str; @@ -1234,9 +1230,9 @@ void complex_vars_of_mule_charset (void) { - staticpro (&Vcharset_hashtable); - Vcharset_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + staticpro (&Vcharset_hash_table); + Vcharset_hash_table = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); /* Predefined character sets. We store them into variables for ease of access. */ @@ -1410,11 +1406,11 @@ composite_char_row_next = 32; composite_char_col_next = 32; - Vcomposite_char_string2char_hashtable = - make_lisp_hashtable (500, HASHTABLE_NONWEAK, HASHTABLE_EQUAL); - Vcomposite_char_char2string_hashtable = - make_lisp_hashtable (500, HASHTABLE_NONWEAK, HASHTABLE_EQ); - staticpro (&Vcomposite_char_string2char_hashtable); - staticpro (&Vcomposite_char_char2string_hashtable); + Vcomposite_char_string2char_hash_table = + make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQUAL); + Vcomposite_char_char2string_hash_table = + make_lisp_hash_table (500, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + staticpro (&Vcomposite_char_string2char_hash_table); + staticpro (&Vcomposite_char_char2string_hash_table); } diff -r 76b7d63099ad -r 8626e4521993 src/mule-coding.c --- a/src/mule-coding.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/mule-coding.c Mon Aug 13 11:07:10 2007 +0200 @@ -75,7 +75,7 @@ Lisp_Object Qctext; -Lisp_Object Vcoding_system_hashtable; +Lisp_Object Vcoding_system_hash_table; int enable_multibyte_characters; @@ -220,27 +220,27 @@ { 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) @@ -249,21 +249,21 @@ { 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; default: break; } - (markobj) (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys)); + markobj (CODING_SYSTEM_PRE_WRITE_CONVERSION (codesys)); return CODING_SYSTEM_POST_READ_CONVERSION (codesys); } @@ -334,11 +334,11 @@ { 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 */ } } @@ -411,7 +411,7 @@ return coding_system_or_name; CHECK_SYMBOL (coding_system_or_name); - return Fgethash (coding_system_or_name, Vcoding_system_hashtable, Qnil); + return Fgethash (coding_system_or_name, Vcoding_system_hash_table, Qnil); } DEFUN ("get-coding-system", Fget_coding_system, 1, 1, 0, /* @@ -465,7 +465,7 @@ 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; @@ -855,7 +855,7 @@ { 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; } } @@ -876,7 +876,7 @@ 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); } { @@ -1702,7 +1702,7 @@ 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 @@ -2141,7 +2141,7 @@ 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 @@ -2692,7 +2692,7 @@ Since the number of characters in Big5 is larger than maximum characters in Emacs' charset (96x96), it can't be handled as one - charset. So, in Emacs, Big5 is devided into two: `charset-big5-1' + charset. So, in Emacs, Big5 is divided into two: `charset-big5-1' and `charset-big5-2'. Both s are TYPE94x94. The former contains frequently used characters and the latter contains less frequently used characters. */ @@ -4428,17 +4428,25 @@ /* 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'! */ -#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) +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); + case FORMAT_CTEXT: + return Fget_coding_system (Qctext); + default: + return Qnil; + } +} CONST Extbyte * convert_to_external_format (CONST Bufbyte *ptr, @@ -4446,7 +4454,7 @@ 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); @@ -4514,7 +4522,7 @@ 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); @@ -4749,9 +4757,9 @@ void complex_vars_of_mule_coding (void) { - staticpro (&Vcoding_system_hashtable); - Vcoding_system_hashtable = make_lisp_hashtable (50, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + staticpro (&Vcoding_system_hash_table); + Vcoding_system_hash_table = + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); the_codesys_prop_dynarr = Dynarr_new (codesys_prop); diff -r 76b7d63099ad -r 8626e4521993 src/mule-mcpath.c --- a/src/mule-mcpath.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/mule-mcpath.c Mon Aug 13 11:07:10 2007 +0200 @@ -217,7 +217,7 @@ path = (unsigned char *) getcwd ((char *)buffer, MAXPATHLEN); if (path) { - /* here, shoule be (path == buffer). */ + /* here, should be (path == buffer). */ path = (unsigned char *) xmalloc (MC_MAXPATHLEN); /* MSDOS */ if (path) { diff -r 76b7d63099ad -r 8626e4521993 src/mule-wnnfns.c --- a/src/mule-wnnfns.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/mule-wnnfns.c Mon Aug 13 11:07:10 2007 +0200 @@ -285,7 +285,7 @@ #define WNNSERVER_T 2 #define WNNSERVER_K 3 -int check_wnn_server_type (void); +int check_wnn_server_type (void); void w2m (w_char *wp, unsigned char *mp, unsigned char lb); void m2w (unsigned char *mp, w_char *wp); void w2y (w_char *w); @@ -348,7 +348,7 @@ case WNNSERVER_C: langname = "zh_CN"; break; -/* +/* case WNNSERVER_T: strcpy (langname, "zh_TW"); break; @@ -408,7 +408,7 @@ DEFUN ("wnn-server-close", Fwnn_close, 0, 0, 0, /* -Close the connection to jserver, Dictionary and friquency files +Close the connection to jserver, Dictionary and frequency files are not saved. */ ()) @@ -418,13 +418,13 @@ if (!wnnfns_buf[snum]) return Qnil; if (wnnfns_env_norm[snum]) { - if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_norm[snum]); + if (NILP (Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_norm[snum]); else jl_env_sticky_e (wnnfns_env_norm[snum]); jl_disconnect (wnnfns_env_norm[snum]); } if (wnnfns_env_rev[snum]) { - if (EQ(Vwnnenv_sticky, Qnil)) jl_env_un_sticky_e (wnnfns_env_rev[snum]); + if (NILP (Vwnnenv_sticky)) jl_env_un_sticky_e (wnnfns_env_rev[snum]); else jl_env_sticky_e (wnnfns_env_rev[snum]); jl_disconnect (wnnfns_env_rev[snum]); } @@ -447,21 +447,21 @@ CHECK_STRING (args[0]); CHECK_STRING (args[1]); CHECK_INT (args[2]); - if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]); - if (!EQ(args[6], Qnil)) CHECK_STRING (args[6]); + if (! NILP (args[5])) CHECK_STRING (args[5]); + if (! NILP (args[6])) CHECK_STRING (args[6]); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if (jl_dic_add (wnnfns_buf[snum], - XSTRING (args[0])->_data, - XSTRING (args[1])->_data, + XSTRING_DATA (args[0]), + XSTRING_DATA (args[1]), wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT (args[2]), - (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[4], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[5], Qnil)) ? 0 : XSTRING (args[5])->_data, - (EQ(args[6], Qnil)) ? 0 : XSTRING (args[6])->_data, + NILP (args[3]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[4]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[5]) ? 0 : XSTRING_DATA (args[5]), + NILP (args[6]) ? 0 : XSTRING_DATA (args[6]), yes_or_no, puts2 ) < 0) { @@ -496,7 +496,7 @@ int cnt, i; unsigned char comment[1024]; Lisp_Object val; - int snum; + int snum; unsigned char lb; if ((snum = check_wnn_server_type ()) == -1) return Qnil; @@ -529,7 +529,7 @@ DEFUN ("wnn-server-dict-comment", Fwnn_dict_comment, 2, 2, 0, /* Set comment to dictionary specified by DIC-NUMBER. Comment string COMMENT -*/ +*/ (dicno, comment)) { w_char wbuf[512]; @@ -538,8 +538,8 @@ CHECK_STRING (comment); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (comment)->_data, wbuf); - if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0) + m2w (XSTRING_DATA (comment), wbuf); + if (jl_dic_comment_set (wnnfns_buf[snum], XINT (dicno), wbuf) < 0) return Qnil; return Qt; } @@ -552,7 +552,7 @@ { int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; - if (EQ(rev, Qnil)) + if (NILP (rev)) { if ((!wnnfns_buf[snum]) || (!wnnfns_env_norm[snum])) return Qnil; jl_env_set (wnnfns_buf[snum], wnnfns_env_norm[snum]); @@ -578,15 +578,15 @@ CHECK_STRING (hstring); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (hstring)->_data, wbuf); + m2w (XSTRING_DATA (hstring), wbuf); if (snum == WNNSERVER_C) w2y (wbuf); #ifdef WNN6 - if ((cnt = jl_fi_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) + if ((cnt = jl_fi_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) return Qnil; #else - if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) + if ((cnt = jl_ren_conv (wnnfns_buf[snum], wbuf, 0, -1, WNN_USE_MAE)) < 0) return Qnil; #endif return make_int (cnt); @@ -696,7 +696,7 @@ CHECK_INT (offset); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - if (EQ(dai, Qnil)) + if (NILP (dai)) { if (jl_set_jikouho (wnnfns_buf[snum], XINT (offset)) < 0) return Qnil; } @@ -722,11 +722,11 @@ no = XINT (bunNo); #ifdef WNN6 if ((cnt = jl_fi_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE, - (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0) + NILP (dai) ? WNN_SHO : WNN_DAI)) < 0) return Qnil; #else if ((cnt = jl_nobi_conv (wnnfns_buf[snum], no, XINT(len), -1, WNN_USE_MAE, - (EQ(dai, Qnil)) ? WNN_SHO : WNN_DAI)) < 0) + NILP (dai) ? WNN_SHO : WNN_DAI)) < 0) return Qnil; #endif return make_int (cnt); @@ -844,7 +844,7 @@ int no; int snum; if ((snum = check_wnn_server_type ()) == -1) return Qnil; - if (EQ(bunNo, Qnil)) no = -1; + if (NILP (bunNo)) no = -1; else { CHECK_INT (bunNo); @@ -875,13 +875,13 @@ CHECK_INT (hinsi); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (yomi)->_data, yomi_buf); + m2w (XSTRING_DATA (yomi), yomi_buf); if (snum == WNNSERVER_C) w2y (yomi_buf); - m2w (XSTRING (kanji)->_data, kanji_buf); - m2w (XSTRING (comment)->_data, comment_buf); + m2w (XSTRING_DATA (kanji), kanji_buf); + m2w (XSTRING_DATA (comment), comment_buf); if (jl_word_add (wnnfns_buf[snum], XINT (dicno), yomi_buf, kanji_buf, - comment_buf, XINT (hinsi), 0) < 0) + comment_buf, XINT (hinsi), 0) < 0) return Qnil; else return Qt; } @@ -992,7 +992,7 @@ if ((snum = check_wnn_server_type ()) == -1) return Qnil; lb = lb_wnn_server_type[snum]; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (yomi)->_data, wbuf); + m2w (XSTRING_DATA (yomi), wbuf); if (snum == WNNSERVER_C) w2y (wbuf); if ((count = jl_word_search_by_env (wnnfns_buf[snum], @@ -1080,7 +1080,7 @@ CHECK_INT (val); setval = XINT (val); if (EQ (key, Qwnn_n)) param.n = setval; - else if (EQ (key, Qwnn_nsho)) param.nsho = setval; + else if (EQ (key, Qwnn_nsho)) param.nsho = setval; else if (EQ (key, Qwnn_hindo)) param.p1 = setval; else if (EQ (key, Qwnn_len)) param.p2 = setval; else if (EQ (key, Qwnn_jiri)) param.p3 = setval; @@ -1106,21 +1106,21 @@ #if 0 printf("wnn_n = %d\n",param.n); printf("wnn_nsho = %d\n",param.nsho); - printf("wnn_hindo = %d\n",param.p1); - printf("wnn_len = %d\n",param.p2); - printf("wnn_jiri = %d\n",param.p3); - printf("wnn_flag = %d\n",param.p4); - printf("wnn_jisho = %d\n",param.p5); - printf("wnn_sbn = %d\n",param.p6); - printf("wnn_dbn_len = %d\n",param.p7); - printf("wnn_sbn_cnt = %d\n",param.p8); - printf("wnn_suuji = %d\n",param.p9); - printf("wnn_kana = %d\n",param.p10); - printf("wnn_eisuu = %d\n",param.p11); - printf("wnn_kigou = %d\n",param.p12); - printf("wnn_toji_kakko = %d\n",param.p13); - printf("wnn_fuzokogo = %d\n",param.p14); - printf("wnn_kaikakko = %d\n",param.p15); + printf("wnn_hindo = %d\n",param.p1); + printf("wnn_len = %d\n",param.p2); + printf("wnn_jiri = %d\n",param.p3); + printf("wnn_flag = %d\n",param.p4); + printf("wnn_jisho = %d\n",param.p5); + printf("wnn_sbn = %d\n",param.p6); + printf("wnn_dbn_len = %d\n",param.p7); + printf("wnn_sbn_cnt = %d\n",param.p8); + printf("wnn_suuji = %d\n",param.p9); + printf("wnn_kana = %d\n",param.p10); + printf("wnn_eisuu = %d\n",param.p11); + printf("wnn_kigou = %d\n",param.p12); + printf("wnn_toji_kakko = %d\n",param.p13); + printf("wnn_fuzokogo = %d\n",param.p14); + printf("wnn_kaikakko = %d\n",param.p15); #endif rc = jl_param_set (wnnfns_buf[snum], ¶m); @@ -1175,7 +1175,7 @@ CHECK_STRING (file); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING (file)->_data) < 0) + if (jl_fuzokugo_set (wnnfns_buf[snum], XSTRING_DATA (file)) < 0) return Qnil; return Qt; } @@ -1246,7 +1246,7 @@ if ((snum = check_wnn_server_type ()) == -1) return Qnil; lb = lb_wnn_server_type[snum]; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (name)->_data, wbuf); + m2w (XSTRING_DATA (name), wbuf); if ((cnt = jl_hinsi_list (wnnfns_buf[snum], XINT (dicno), wbuf, &area)) < 0) return Qnil; if (cnt == 0) return make_int (0); @@ -1289,21 +1289,21 @@ int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); - if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]); + if (! NILP (args[3])) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if(jl_fi_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, - XSTRING(args[1])->_data, - WNN_FI_SYSTEM_DICT, - WNN_DIC_RDONLY, - (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - 0, - (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data, - yes_or_no, - puts2 ) < 0) { + XSTRING_DATA (args[0]), + XSTRING_DATA (args[1]), + WNN_FI_SYSTEM_DICT, + WNN_DIC_RDONLY, + NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + 0, + NILP (args[3]) ? 0 : XSTRING_DATA (args[3]), + yes_or_no, + puts2 ) < 0) { UNGCPRO; return Qnil; } @@ -1322,22 +1322,22 @@ int snum; CHECK_STRING (args[0]); CHECK_STRING (args[1]); - if (!EQ(args[4], Qnil)) CHECK_STRING (args[4]); - if (!EQ(args[5], Qnil)) CHECK_STRING (args[5]); + if (! NILP (args[4])) CHECK_STRING (args[4]); + if (! NILP (args[5])) CHECK_STRING (args[5]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); gcpro1.nvars = nargs; if(jl_fi_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, - XSTRING(args[1])->_data, - WNN_FI_USER_DICT, - (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[3], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW, - (EQ(args[4], Qnil)) ? 0 : XSTRING(args[4])->_data, - (EQ(args[5], Qnil)) ? 0 : XSTRING(args[5])->_data, - yes_or_no, - puts2 ) < 0) { + XSTRING_DATA (args[0]), + XSTRING_DATA (args[1]), + WNN_FI_USER_DICT, + NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[3]) ? WNN_DIC_RDONLY : WNN_DIC_RW, + NILP (args[4]) ? 0 : XSTRING_DATA (args[4]), + NILP (args[5]) ? 0 : XSTRING_DATA (args[5]), + yes_or_no, + puts2 ) < 0) { UNGCPRO; return Qnil; } @@ -1359,7 +1359,7 @@ struct wnn_henkan_env henv; CHECK_STRING (args[0]); CHECK_INT (args[1]); - if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]); + if (! NILP (args[3])) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); @@ -1371,12 +1371,12 @@ dic_no = js_get_autolearning_dic(cur_env, WNN_MUHENKAN_LEARNING); if (dic_no == WNN_NO_LEARNING) { if((dic_no = jl_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, + XSTRING_DATA (args[0]), 0, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT(args[1]), WNN_DIC_RW, WNN_DIC_RW, - (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data, + NILP (args[3]) ? 0 : XSTRING_DATA (args[3]), 0, yes_or_no, puts2)) < 0) { @@ -1393,7 +1393,7 @@ } } vmask |= WNN_ENV_MUHENKAN_LEARN_MASK; - henv.muhenkan_flag = (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW; + henv.muhenkan_flag = NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) { @@ -1418,7 +1418,7 @@ struct wnn_henkan_env henv; CHECK_STRING (args[0]); CHECK_INT (args[1]); - if (!EQ(args[3], Qnil)) CHECK_STRING (args[3]); + if (! NILP (args[3])) CHECK_STRING (args[3]); if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; GCPRO1 (*args); @@ -1430,12 +1430,12 @@ dic_no = js_get_autolearning_dic(cur_env, WNN_BUNSETSUGIRI_LEARNING); if (dic_no == WNN_NO_LEARNING) { if((dic_no = jl_dic_add(wnnfns_buf[snum], - XSTRING(args[0])->_data, + XSTRING_DATA (args[0]), 0, wnnfns_norm ? WNN_DIC_ADD_NOR : WNN_DIC_ADD_REV, XINT(args[1]), WNN_DIC_RW, WNN_DIC_RW, - (EQ(args[3], Qnil)) ? 0 : XSTRING(args[3])->_data, + NILP (args[3]) ? 0 : XSTRING_DATA (args[3]), 0, yes_or_no, puts2)) < 0) { @@ -1452,7 +1452,7 @@ } } vmask |= WNN_ENV_BUNSETSUGIRI_LEARN_MASK; - henv.bunsetsugiri_flag = (EQ(args[2], Qnil)) ? WNN_DIC_RDONLY : WNN_DIC_RW; + henv.bunsetsugiri_flag = NILP (args[2]) ? WNN_DIC_RDONLY : WNN_DIC_RW; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) { @@ -1473,8 +1473,8 @@ struct wnn_henkan_env henv; if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; - vmask |= WNN_ENV_LAST_IS_FIRST_MASK; - henv.last_is_first_flag = (EQ(mode, Qnil)) ? False : True; + vmask |= WNN_ENV_LAST_IS_FIRST_MASK; + henv.last_is_first_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1492,7 +1492,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_COMPLEX_CONV_MASK; - henv.complex_flag = (EQ(mode, Qnil)) ? False : True; + henv.complex_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1510,7 +1510,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_OKURI_LEARN_MASK; - henv.okuri_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.okuri_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1553,7 +1553,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_PREFIX_LEARN_MASK; - henv.prefix_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.prefix_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1594,7 +1594,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_SUFFIX_LEARN_MASK; - henv.suffix_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.suffix_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1612,7 +1612,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_COMMON_LAERN_MASK; - henv.common_learn_flag = (EQ(mode, Qnil)) ? False : True; + henv.common_learn_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1728,7 +1728,7 @@ if ((snum = check_wnn_server_type()) == -1) return Qnil; if(!wnnfns_buf[snum]) return Qnil; vmask |= WNN_ENV_YURAGI_MASK; - henv.yuragi_flag = (EQ(mode, Qnil)) ? False : True; + henv.yuragi_flag = NILP (mode) ? False : True; if(jl_set_henkan_env(wnnfns_buf[snum], vmask, &henv) < 0) return Qnil; @@ -1778,7 +1778,7 @@ CHECK_STRING (name); if ((snum = check_wnn_server_type ()) == -1) return Qnil; if (!wnnfns_buf[snum]) return Qnil; - m2w (XSTRING (name)->_data, w_buf); + m2w (XSTRING_DATA (name), w_buf); if ((no = jl_hinsi_number (wnnfns_buf[snum], w_buf)) < 0) return Qnil; return make_int (no); } @@ -1926,7 +1926,7 @@ if (EQ(Vwnn_server_type, Qcserver)) { len = cwnn_yincod_pzy (pzy, wc, - (EQ(Vcwnn_zhuyin, Qnil)) + NILP (Vcwnn_zhuyin) ? CWNN_PINYIN : CWNN_ZHUYIN); for (i = 0; i < len; i++) @@ -1972,7 +1972,7 @@ m2w (unsigned char *mp, w_char *wp) { unsigned int ch; - + while ((ch = *mp++) != 0) { if (BUFBYTE_LEADING_BYTE_P (ch)) @@ -2032,7 +2032,7 @@ w++; pin++; } len = cwnn_pzy_yincod (ybuf, pbuf, - (EQ(Vcwnn_zhuyin, Qnil)) ? CWNN_PINYIN : CWNN_ZHUYIN); + NILP (Vcwnn_zhuyin) ? CWNN_PINYIN : CWNN_ZHUYIN); if (len <= 0) return; diff -r 76b7d63099ad -r 8626e4521993 src/nas.c --- a/src/nas.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/nas.c Mon Aug 13 11:07:10 2007 +0200 @@ -55,20 +55,19 @@ #ifdef emacs #include #include "lisp.h" +#include "sysdep.h" +#include "syssignal.h" #endif -#if __STDC__ || defined (STDC_HEADERS) -# include -# include -# include -#endif +#include +#include +#include +#include #ifdef HAVE_UNISTD_H #include #endif -#include -#include "syssignal.h" #undef LITTLE_ENDIAN #undef BIG_ENDIAN diff -r 76b7d63099ad -r 8626e4521993 src/nt.c --- a/src/nt.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/nt.c Mon Aug 13 11:07:10 2007 +0200 @@ -1169,7 +1169,7 @@ return -1; } - /* Emulate Unix behaviour - newname is deleted if it already exists + /* Emulate Unix behavior - newname is deleted if it already exists (at least if it is a file; don't do this for directories). However, don't do this if we are just changing the case of the file name - we will end up deleting the file we are trying to rename! */ @@ -1288,7 +1288,7 @@ unsigned hash; /* Get the truly canonical filename, if it exists. (Note: this - doesn't resolve aliasing due to subst commands, or recognise hard + doesn't resolve aliasing due to subst commands, or recognize hard links. */ if (!win32_get_long_filename ((char *)name, fullname, MAX_PATH)) abort (); @@ -1390,8 +1390,8 @@ } else if (!NILP (Vmswindows_get_true_file_attributes)) { - /* This is more accurate in terms of gettting the correct number - of links, but is quite slow (it is noticable when Emacs is + /* This is more accurate in terms of getting the correct number + of links, but is quite slow (it is noticeable when Emacs is making a list of file name completions). */ BY_HANDLE_FILE_INFORMATION info; @@ -1833,7 +1833,7 @@ */ const int timer_prec = 10; -/* Last itimevals, as set by calls to setitimer */ +/* Last itimervals, as set by calls to setitimer */ static struct itimerval it_alarm; static struct itimerval it_prof; @@ -1863,7 +1863,7 @@ if (tv->tv_sec == 0 && tv->tv_usec == 0) return 0; - /* Conver to ms and divide by denom */ + /* Convert to ms and divide by denom */ res = (tv->tv_sec * 1000 + (tv->tv_usec + 500) / 1000) / denom; /* Converge to minimum timer resolution */ diff -r 76b7d63099ad -r 8626e4521993 src/ntheap.c --- a/src/ntheap.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/ntheap.c Mon Aug 13 11:07:10 2007 +0200 @@ -111,7 +111,7 @@ static char * allocate_heap (void) { - /* The base address for our GNU malloc heap is chosen in conjuction + /* The base address for our GNU malloc heap is chosen in conjunction with the link settings for temacs.exe which control the stack size, the initial default process heap size and the executable image base address. The link settings and the malloc heap base below must all diff -r 76b7d63099ad -r 8626e4521993 src/ntproc.c --- a/src/ntproc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/ntproc.c Mon Aug 13 11:07:10 2007 +0200 @@ -58,7 +58,7 @@ /* Control whether spawnve quotes arguments as necessary to ensure correct parsing by child process. Because not all uses of spawnve - are careful about constructing argv arrays, we make this behaviour + are careful about constructing argv arrays, we make this behavior conditional (off by default). */ Lisp_Object Vwin32_quote_process_args; @@ -620,7 +620,7 @@ The Win32 GNU-based library from Cygnus doubles quotes to escape them, while MSVC uses backslash for escaping. (Actually the MSVC - startup code does attempt to recognise doubled quotes and accept + startup code does attempt to recognize doubled quotes and accept them, but gets it wrong and ends up requiring three quotes to get a single embedded quote!) So by default we decide whether to use quote or backslash as the escape character based on whether the @@ -628,7 +628,7 @@ Note that using backslash to escape embedded quotes requires additional special handling if an embedded quote is already - preceeded by backslash, or if an arg requiring quoting ends with + preceded by backslash, or if an arg requiring quoting ends with backslash. In such cases, the run of escape characters needs to be doubled. For consistency, we apply this special handling as long as the escape character is not quote. @@ -724,7 +724,7 @@ #if 0 /* This version does not escape quotes if they occur at the beginning or end of the arg - this could lead to incorrect - behaviour when the arg itself represents a command line + behavior when the arg itself represents a command line containing quoted args. I believe this was originally done as a hack to make some things work, before `win32-quote-process-args' was added. */ @@ -1193,7 +1193,7 @@ DEFUN ("win32-get-locale-info", Fwin32_get_locale_info, 1, 2, "", /* "Return information about the Windows locale LCID. By default, return a three letter locale code which encodes the default -language as the first two characters, and the country or regionial variant +language as the first two characters, and the country or regional variant as the third letter. For example, ENU refers to `English (United States)', while ENC means `English (Canadian)'. @@ -1395,7 +1395,7 @@ "Non-nil means attempt to fake realistic inode values. This works by hashing the truename of files, and should detect aliasing between long and short (8.3 DOS) names, but can have -false positives because of hash collisions. Note that determing +false positives because of hash collisions. Note that determining the truename of a file can be slow. */ ); Vwin32_generate_fake_inodes = Qnil; diff -r 76b7d63099ad -r 8626e4521993 src/objects-msw.c --- a/src/objects-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/objects-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -1060,7 +1060,7 @@ COLOR_INSTANCE_MSWINDOWS_COLOR (c) = color; return 1; } - maybe_signal_simple_error ("unrecognized color", name, Qcolor, errb); + maybe_signal_simple_error ("Unrecognized color", name, Qcolor, errb); return(0); } diff -r 76b7d63099ad -r 8626e4521993 src/objects-tty.c --- a/src/objects-tty.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/objects-tty.c Mon Aug 13 11:07:10 2007 +0200 @@ -171,7 +171,7 @@ tty_mark_color_instance (struct Lisp_Color_Instance *c, void (*markobj) (Lisp_Object)) { - ((markobj) (COLOR_INSTANCE_TTY_SYMBOL (c))); + markobj (COLOR_INSTANCE_TTY_SYMBOL (c)); } static void @@ -259,7 +259,7 @@ tty_mark_font_instance (struct Lisp_Font_Instance *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FONT_INSTANCE_TTY_CHARSET (f))); + markobj (FONT_INSTANCE_TTY_CHARSET (f)); } static void diff -r 76b7d63099ad -r 8626e4521993 src/objects-x.c --- a/src/objects-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/objects-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -114,7 +114,7 @@ status = 1; else { - int rd, gr, bl; + int rd, gr, bl; /* ### JH: I'm punting here, knowing that doing this will at least draw the color correctly. However, unless we convert all of the functions that allocate colors (graphics @@ -209,13 +209,11 @@ Bytecount len, Error_behavior errb) { Display *dpy; - Screen *xs; Colormap cmap; Visual *visual; int result; dpy = DEVICE_X_DISPLAY (d); - xs = DefaultScreenOfDisplay (dpy); cmap = DEVICE_X_COLORMAP(d); visual = DEVICE_X_VISUAL (d); @@ -229,14 +227,14 @@ } if (!result) { - maybe_signal_simple_error ("unrecognized color", make_string (name, len), + maybe_signal_simple_error ("Unrecognized color", make_string (name, len), Qcolor, errb); return 0; } result = allocate_nearest_color (dpy, cmap, visual, color); if (!result) { - maybe_signal_simple_error ("couldn't allocate color", + maybe_signal_simple_error ("Couldn't allocate color", make_string (name, len), Qcolor, errb); return 0; } @@ -367,7 +365,7 @@ if (!xf) { - maybe_signal_simple_error ("couldn't load font", f->name, + maybe_signal_simple_error ("Couldn't load font", f->name, Qfont, errb); return 0; } @@ -452,7 +450,7 @@ x_mark_font_instance (struct Lisp_Font_Instance *f, void (*markobj) (Lisp_Object)) { - ((markobj) (FONT_INSTANCE_X_TRUENAME (f))); + markobj (FONT_INSTANCE_X_TRUENAME (f)); } static void @@ -498,7 +496,7 @@ also picking 100dpi adobe fonts over 75dpi adobe fonts even though the 75dpi are in the path earlier) but sometimes appears to be doing something else entirely (for example, removing the bitsream fonts from the path will - cause the 75dpi adobe fonts to be used instead of the100dpi, even though + cause the 75dpi adobe fonts to be used instead of the 100dpi, even though their relative positions in the path (and their names!) have not changed). The documentation for XSetFontPath() seems to indicate that the order of @@ -509,7 +507,7 @@ truename of the font. However, there are two problems with using this: the first is that the X Protocol Document is quite explicit that all properties are optional, so we can't depend on it being there. The second is that - it's concievable that this alleged truename isn't actually accessible as a + it's conceivable that this alleged truename isn't actually accessible as a font, due to some difference of opinion between the font designers and whoever installed the font on the system. @@ -566,7 +564,7 @@ static int valid_x_font_name_p (Display *dpy, char *name) { - /* Maybe this should be implemented by callign XLoadFont and trapping + /* Maybe this should be implemented by calling XLoadFont and trapping the error. That would be a lot of work, and wasteful as hell, but might be more correct. */ @@ -783,7 +781,7 @@ Lisp_Object font_instance; XSETFONT_INSTANCE (font_instance, f); - maybe_signal_simple_error ("couldn't determine font truename", + maybe_signal_simple_error ("Couldn't determine font truename", font_instance, Qfont, errb); /* Ok, just this once, return the font name as the truename. (This is only used by Fequal() right now.) */ diff -r 76b7d63099ad -r 8626e4521993 src/objects.c --- a/src/objects.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/objects.c Mon Aug 13 11:07:10 2007 +0200 @@ -60,7 +60,7 @@ mark_color_instance (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); - ((markobj) (c->name)); + markobj (c->name); if (!NILP (c->device)) /* Vthe_null_color_instance */ MAYBE_DEVMETH (XDEVICE (c->device), mark_color_instance, (c, markobj)); @@ -100,18 +100,16 @@ } 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; + struct Lisp_Color_Instance *c1 = XCOLOR_INSTANCE (obj1); + struct Lisp_Color_Instance *c2 = XCOLOR_INSTANCE (obj2); - 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)); + return (c1 == c2) || + ((EQ (c1->device, c2->device)) && + DEVICEP (c1->device) && + HAS_DEVMETH_P (XDEVICE (c1->device), color_instance_equal) && + DEVMETH (XDEVICE (c1->device), color_instance_equal, (c1, c2, depth))); } static unsigned long @@ -243,7 +241,7 @@ { struct Lisp_Font_Instance *f = XFONT_INSTANCE (obj); - ((markobj) (f->name)); + markobj (f->name); if (!NILP (f->device)) /* Vthe_null_font_instance */ MAYBE_DEVMETH (XDEVICE (f->device), mark_font_instance, (f, markobj)); @@ -284,11 +282,11 @@ this means the `equal' could cause XListFonts to be run the first time. */ static int -font_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth) +font_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { /* #### should this be moved into a device method? */ - return internal_equal (font_instance_truename_internal (o1, ERROR_ME_NOT), - font_instance_truename_internal (o2, ERROR_ME_NOT), + return internal_equal (font_instance_truename_internal (obj1, ERROR_ME_NOT), + font_instance_truename_internal (obj2, ERROR_ME_NOT), depth + 1); } @@ -483,8 +481,8 @@ { struct Lisp_Specifier *color = XCOLOR_SPECIFIER (obj); - ((markobj) (COLOR_SPECIFIER_FACE (color))); - ((markobj) (COLOR_SPECIFIER_FACE_PROPERTY (color))); + markobj (COLOR_SPECIFIER_FACE (color)); + markobj (COLOR_SPECIFIER_FACE_PROPERTY (color)); } /* No equal or hash methods; ignore the face the color is based off @@ -499,7 +497,6 @@ so we can freely error. */ Lisp_Object device = DFW_DEVICE (domain); struct device *d = XDEVICE (device); - Lisp_Object instance; if (COLOR_INSTANCEP (instantiator)) { @@ -516,7 +513,8 @@ if (STRINGP (instantiator)) { /* First, look to see if we can retrieve a cached value. */ - instance = Fgethash (instantiator, d->color_instance_cache, Qunbound); + Lisp_Object instance = + Fgethash (instantiator, d->color_instance_cache, Qunbound); /* Otherwise, make a new one. */ if (UNBOUNDP (instance)) { @@ -661,8 +659,8 @@ { struct Lisp_Specifier *font = XFONT_SPECIFIER (obj); - ((markobj) (FONT_SPECIFIER_FACE (font))); - ((markobj) (FONT_SPECIFIER_FACE_PROPERTY (font))); + markobj (FONT_SPECIFIER_FACE (font)); + markobj (FONT_SPECIFIER_FACE_PROPERTY (font)); } /* No equal or hash methods; ignore the face the font is based off @@ -736,17 +734,17 @@ iterate over all possible fonts, and a regexp match on each one. So we cache the results. */ Lisp_Object matching_font = Qunbound; - Lisp_Object hashtab = Fgethash (matchspec, d->charset_font_cache, + Lisp_Object hash_table = Fgethash (matchspec, d->charset_font_cache, Qunbound); - if (UNBOUNDP (hashtab)) + if (UNBOUNDP (hash_table)) { /* need to make a sub hash table. */ - hashtab = make_lisp_hashtable (20, HASHTABLE_KEY_WEAK, - HASHTABLE_EQUAL); - Fputhash (matchspec, hashtab, d->charset_font_cache); + hash_table = make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, + HASH_TABLE_EQUAL); + Fputhash (matchspec, hash_table, d->charset_font_cache); } else - matching_font = Fgethash (instantiator, hashtab, Qunbound); + matching_font = Fgethash (instantiator, hash_table, Qunbound); if (UNBOUNDP (matching_font)) { @@ -755,7 +753,7 @@ DEVMETH_OR_GIVEN (d, find_charset_font, (device, instantiator, matchspec), instantiator); - Fputhash (instantiator, matching_font, hashtab); + Fputhash (instantiator, matching_font, hash_table); } if (NILP (matching_font)) return Qunbound; @@ -868,8 +866,8 @@ { struct Lisp_Specifier *face_boolean = XFACE_BOOLEAN_SPECIFIER (obj); - ((markobj) (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean))); - ((markobj) (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean))); + markobj (FACE_BOOLEAN_SPECIFIER_FACE (face_boolean)); + markobj (FACE_BOOLEAN_SPECIFIER_FACE_PROPERTY (face_boolean)); } /* No equal or hash methods; ignore the face the face-boolean is based off diff -r 76b7d63099ad -r 8626e4521993 src/offix.c --- a/src/offix.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/offix.c Mon Aug 13 11:07:10 2007 +0200 @@ -316,7 +316,7 @@ } /*================================================================== DndGetData - * Return a pointer to the current data. Se HOWTO for more details. + * Return a pointer to the current data. See HOWTO for more details. *===========================================================================*/ void DndGetData(XEvent *event, unsigned char **Data,unsigned long *Size) diff -r 76b7d63099ad -r 8626e4521993 src/opaque.c --- a/src/opaque.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/opaque.c Mon Aug 13 11:07:10 2007 +0200 @@ -42,6 +42,7 @@ #include #include "lisp.h" #include "opaque.h" +#include Lisp_Object Qopaquep; @@ -55,62 +56,76 @@ static Lisp_Object mark_opaque (Lisp_Object obj, void (*markobj) (Lisp_Object)) { + Lisp_Opaque *p = XOPAQUE (obj); + Lisp_Object size_or_chain = p->size_or_chain; #ifdef ERROR_CHECK_GC if (!in_opaque_list_marking) /* size is non-int for objects on an opaque free list. We sure as hell better not be marking any of these objects unless we're marking an opaque list. */ - assert (INTP (XOPAQUE (obj)->size_or_chain)); + assert (GC_INTP (size_or_chain)); else /* marking an opaque on the free list doesn't do any recursive markings, so we better not have non-freed opaques on a free list. */ - assert (!INTP (XOPAQUE (obj)->size_or_chain)); + assert (!GC_INTP (size_or_chain)); #endif - if (INTP (XOPAQUE (obj)->size_or_chain) && XOPAQUE_MARKFUN (obj)) - return XOPAQUE_MARKFUN (obj) (obj, markobj); + if (GC_INTP (size_or_chain) && OPAQUE_MARKFUN (p)) + return OPAQUE_MARKFUN (p) (obj, markobj); else - return XOPAQUE (obj)->size_or_chain; + return size_or_chain; } /* Should never, ever be called. (except by an external debugger) */ static void print_opaque (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { + CONST Lisp_Opaque *p = XOPAQUE (obj); char buf[200]; - if (INTP (XOPAQUE (obj)->size_or_chain)) - sprintf (buf, "#", - (long) XOPAQUE_SIZE (obj), (unsigned long) XPNTR (obj)); + char size_buf[50]; + + if (INTP (p->size_or_chain)) + sprintf (size_buf, "size=%lu", (unsigned long) OPAQUE_SIZE (p)); else - sprintf (buf, "#", - (unsigned long) XPNTR (obj)); + sprintf (size_buf, "freed"); + + sprintf (buf, "#", + size_buf, (unsigned long) p); write_c_string (buf, printcharfun); } static size_t sizeof_opaque (CONST void *header) { - CONST struct Lisp_Opaque *p = (CONST struct Lisp_Opaque *) header; - if (!INTP (p->size_or_chain)) - return sizeof (*p); - return sizeof (*p) + XINT (p->size_or_chain) - sizeof (int); + CONST Lisp_Opaque *p = (CONST Lisp_Opaque *) header; + return offsetof (Lisp_Opaque, data) + + (GC_INTP (p->size_or_chain) ? XINT (p->size_or_chain) : 0); } +/* Return an opaque object of size SIZE. + If DATA is OPAQUE_CLEAR, the object's data is memset to '\0' bytes. + If DATA is OPAQUE_UNINIT, the object's data is uninitialized. + Else the object's data is initialized by copying from DATA. */ Lisp_Object -make_opaque (int size, CONST void *data) +make_opaque (size_t size, CONST void *data) { - struct Lisp_Opaque *p = (struct Lisp_Opaque *) - alloc_lcrecord (sizeof (*p) + size - sizeof (int), lrecord_opaque); - Lisp_Object val; - + Lisp_Opaque *p = (Lisp_Opaque *) + alloc_lcrecord (offsetof (Lisp_Opaque, data) + size, lrecord_opaque); p->markfun = 0; p->size_or_chain = make_int (size); - if (data) - memcpy (p->data, data, size); + + if (data == OPAQUE_CLEAR) + memset (p->data, '\0', size); + else if (data == OPAQUE_UNINIT) + DO_NOTHING; else - memset (p->data, 0, size); - XSETOPAQUE (val, p); - return val; + memcpy (p->data, data, size); + + { + Lisp_Object val; + XSETOPAQUE (val, p); + return val; + } } /* This will not work correctly for opaques with subobjects! */ @@ -118,17 +133,14 @@ static int equal_opaque (Lisp_Object obj1, Lisp_Object obj2, int depth) { + size_t size; #ifdef DEBUG_XEMACS assert (!XOPAQUE_MARKFUN (obj1) && !XOPAQUE_MARKFUN (obj2)); - assert (INTP (XOPAQUE(obj1)->size_or_chain)); - assert (INTP (XOPAQUE(obj2)->size_or_chain)); + assert (INTP (XOPAQUE (obj1)->size_or_chain)); + assert (INTP (XOPAQUE (obj2)->size_or_chain)); #endif - if (XOPAQUE_SIZE(obj1) != XOPAQUE_SIZE(obj2)) - return 0; - return (XOPAQUE_SIZE(obj1) == sizeof(*XOPAQUE_DATA(obj1)) - ? *XOPAQUE_DATA(obj1) == *XOPAQUE_DATA(obj2) - : memcmp (XOPAQUE_DATA(obj1), XOPAQUE_DATA(obj2), - XOPAQUE_SIZE(obj1)) == 0); + return ((size = XOPAQUE_SIZE (obj1)) == XOPAQUE_SIZE (obj2) && + !memcmp (XOPAQUE_DATA (obj1), XOPAQUE_DATA (obj2), size)); } /* This will not work correctly for opaques with subobjects! */ @@ -138,36 +150,36 @@ { #ifdef DEBUG_XEMACS assert (!XOPAQUE_MARKFUN (obj)); - assert (INTP (XOPAQUE(obj)->size_or_chain)); + assert (INTP (XOPAQUE (obj)->size_or_chain)); #endif - if (XOPAQUE_SIZE(obj) == sizeof (unsigned long)) - return (unsigned int) *XOPAQUE_DATA(obj); + if (XOPAQUE_SIZE (obj) == sizeof (unsigned long)) + return *((unsigned long *) XOPAQUE_DATA(obj)); else - return memory_hash (XOPAQUE_DATA(obj), XOPAQUE_SIZE(obj)); + return memory_hash (XOPAQUE_DATA (obj), XOPAQUE_SIZE (obj)); } DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, mark_opaque, print_opaque, 0, equal_opaque, hash_opaque, - sizeof_opaque, struct Lisp_Opaque); + sizeof_opaque, Lisp_Opaque); static Lisp_Object mark_opaque_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) { in_opaque_list_marking++; - (markobj) (XOPAQUE_LIST (obj)->free); + markobj (XOPAQUE_LIST (obj)->free); in_opaque_list_marking--; return Qnil; } Lisp_Object -make_opaque_list (int size, +make_opaque_list (size_t size, Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object))) { Lisp_Object val; - struct Lisp_Opaque_List *p = - alloc_lcrecord_type (struct Lisp_Opaque_List, lrecord_opaque_list); + Lisp_Opaque_List *p = + alloc_lcrecord_type (Lisp_Opaque_List, lrecord_opaque_list); p->markfun = markfun; p->size = size; @@ -178,12 +190,12 @@ DEFINE_LRECORD_IMPLEMENTATION ("opaque-list", opaque_list, mark_opaque_list, internal_object_printer, - 0, 0, 0, struct Lisp_Opaque_List); + 0, 0, 0, Lisp_Opaque_List); Lisp_Object allocate_managed_opaque (Lisp_Object opaque_list, CONST void *data) { - struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); + Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); Lisp_Object val; if (!NILP (li->free)) @@ -208,7 +220,7 @@ void free_managed_opaque (Lisp_Object opaque_list, Lisp_Object opaque) { - struct Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); + Lisp_Opaque_List *li = XOPAQUE_LIST (opaque_list); #ifdef ERROR_CHECK_GC assert (INTP (XOPAQUE (opaque)->size_or_chain)); @@ -226,7 +238,7 @@ (CONST void *) &val); } -/* Be wery wery careful with this. Same admonitions as with +/* Be very very careful with this. Same admonitions as with free_cons() apply. */ void diff -r 76b7d63099ad -r 8626e4521993 src/opaque.h --- a/src/opaque.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/opaque.h Mon Aug 13 11:07:10 2007 +0200 @@ -26,29 +26,34 @@ #ifndef _XEMACS_OPAQUE_H_ #define _XEMACS_OPAQUE_H_ -struct Lisp_Opaque +typedef union { + struct { Lisp_Object obj; } obj; + struct { void *p; } p; + struct { double d; } d; +} max_align_t; + +typedef struct Lisp_Opaque { struct lcrecord_header header; Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object)); /* An integral size for non-freed objects, an opaque or nil for freed objects. */ Lisp_Object size_or_chain; - /* It's actually more space-efficient to declare this as an int - rather than a char, because the structure will get rounded up - in size by the compiler anyway. */ - int data[1]; -}; + max_align_t data[1]; +} Lisp_Opaque; -struct Lisp_Opaque_List +typedef struct Lisp_Opaque_List { struct lcrecord_header header; + /* `markfun' allows you to put lisp objects inside of opaque objects + without having to create a new object type. */ Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object)); Lisp_Object free; - int size; -}; + size_t size; +} Lisp_Opaque_List; -DECLARE_LRECORD (opaque, struct Lisp_Opaque); -#define XOPAQUE(x) XRECORD (x, opaque, struct Lisp_Opaque) +DECLARE_LRECORD (opaque, Lisp_Opaque); +#define XOPAQUE(x) XRECORD (x, opaque, Lisp_Opaque) #define XSETOPAQUE(x, p) XSETRECORD (x, p, opaque) #define OPAQUEP(x) RECORDP (x, opaque) #define GC_OPAQUEP(x) GC_RECORDP (x, opaque) @@ -56,8 +61,8 @@ Opaque pointers should never escape to the Lisp level, so functions should not be doing this. */ -DECLARE_LRECORD (opaque_list, struct Lisp_Opaque_List); -#define XOPAQUE_LIST(x) XRECORD (x, opaque_list, struct Lisp_Opaque_List) +DECLARE_LRECORD (opaque_list, Lisp_Opaque_List); +#define XOPAQUE_LIST(x) XRECORD (x, opaque_list, Lisp_Opaque_List) #define XSETOPAQUE_LIST(x, p) XSETRECORD (x, p, opaque_list) #define OPAQUE_LISTP(x) RECORDP (x, opaque_list) #define GC_OPAQUE_LISTP(x) GC_RECORDP (x, opaque_list) @@ -65,14 +70,18 @@ Opaque lists should never escape to the Lisp level, so functions should not be doing this. */ -Lisp_Object make_opaque (int size, CONST void *data); +/* Alternative DATA arguments to make_opaque */ +#define OPAQUE_CLEAR ((CONST void *) 0) +#define OPAQUE_UNINIT ((CONST void *) -1) + +Lisp_Object make_opaque (size_t size, CONST void *data); Lisp_Object make_opaque_ptr (CONST void *val); Lisp_Object make_opaque_long (long val); void free_opaque_ptr (Lisp_Object ptr); #define OPAQUE_SIZE(op) XINT ((op)->size_or_chain) #define OPAQUE_DATA(op) ((op)->data) -#define OPAQUE_MARKFUN(op) ((op)->markfun) /* What's the point if this? */ +#define OPAQUE_MARKFUN(op) ((op)->markfun) #define XOPAQUE_SIZE(op) OPAQUE_SIZE (XOPAQUE (op)) #define XOPAQUE_DATA(op) OPAQUE_DATA (XOPAQUE (op)) #define XOPAQUE_MARKFUN(op) OPAQUE_MARKFUN (XOPAQUE (op)) @@ -83,7 +92,7 @@ #define set_opaque_long(op, ptr) (get_opaque_long (op) = ptr) #define set_opaque_markfun(op, fun) (XOPAQUE_MARKFUN (op) = fun) -Lisp_Object make_opaque_list (int size, +Lisp_Object make_opaque_list (size_t size, Lisp_Object (*markfun) (Lisp_Object obj, void (*markobj) (Lisp_Object))); diff -r 76b7d63099ad -r 8626e4521993 src/print.c --- a/src/print.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/print.c Mon Aug 13 11:07:10 2007 +0200 @@ -39,6 +39,7 @@ #include "lstream.h" #include "sysfile.h" +#include #include /* Define if not in float.h */ #ifndef DBL_DIG @@ -166,7 +167,7 @@ CONST Bufbyte *newnonreloc = nonreloc; struct gcpro gcpro1, gcpro2; - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return; /* Perhaps not necessary but probably safer. */ @@ -278,7 +279,7 @@ static Lisp_Object print_prepare (Lisp_Object printcharfun, Lisp_Object *frame_kludge) { - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return Qnil; @@ -323,7 +324,7 @@ static void print_finish (Lisp_Object stream, Lisp_Object frame_kludge) { - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return; @@ -341,7 +342,7 @@ clear_echo_area_from_print (f, Qnil, 1); echo_area_append (f, resizing_buffer_stream_ptr (str), Qnil, 0, Lstream_byte_count (str), - Vprint_message_label); + Vprint_message_label); Lstream_delete (str); } } @@ -395,7 +396,7 @@ } void -temp_output_buffer_setup (CONST char *bufname) +temp_output_buffer_setup (Lisp_Object bufname) { /* This function can GC */ struct buffer *old = current_buffer; @@ -406,7 +407,7 @@ so that proper translation on the buffer name can occur. */ #endif - Fset_buffer (Fget_buffer_create (build_string (bufname))); + Fset_buffer (Fget_buffer_create (bufname)); current_buffer->read_only = Qnil; Ferase_buffer (Qnil); @@ -418,7 +419,7 @@ } Lisp_Object -internal_with_output_to_temp_buffer (CONST char *bufname, +internal_with_output_to_temp_buffer (Lisp_Object bufname, Lisp_Object (*function) (Lisp_Object arg), Lisp_Object arg, Lisp_Object same_frame) @@ -429,7 +430,7 @@ GCPRO3 (buf, arg, same_frame); - temp_output_buffer_setup (GETTEXT (bufname)); + temp_output_buffer_setup (bufname); buf = Vstandard_output; arg = (*function) (arg); @@ -454,21 +455,22 @@ (args)) { /* This function can GC */ - struct gcpro gcpro1; - Lisp_Object name; + Lisp_Object name = Qnil; int speccount = specpdl_depth (); - Lisp_Object val; + struct gcpro gcpro1, gcpro2; + Lisp_Object val = Qnil; #ifdef I18N3 /* #### should set the buffer to be translating. See print_internal(). */ #endif - GCPRO1 (args); + GCPRO2 (name, val); name = Feval (XCAR (args)); - UNGCPRO; CHECK_STRING (name); - temp_output_buffer_setup ((char *) XSTRING_DATA (name)); + + temp_output_buffer_setup (name); + UNGCPRO; val = Fprogn (XCDR (args)); @@ -896,23 +898,33 @@ write_char_internal ("(", printcharfun); { - int i = 0; - int max = 0; + 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 */ - if (INTP (Vprint_length)) - max = XINT (Vprint_length); - while (CONSP (obj)) + for (tortoise = obj, len = 0; + CONSP (obj); + obj = XCDR (obj), len++) { - if (i++) + if (len > 0) write_char_internal (" ", printcharfun); - if (max && i > max) + if (EQ (obj, tortoise) && len > 0) + { + if (print_readably) + error ("printing unreadable circular list"); + else + write_c_string ("... ", printcharfun); + break; + } + if (len & 1) + tortoise = XCDR (tortoise); + if (len > max) { write_c_string ("...", printcharfun); break; } - print_internal (XCAR (obj), printcharfun, - escapeflag); - obj = XCDR (obj); + print_internal (XCAR (obj), printcharfun, escapeflag); } } if (!LISTP (obj)) @@ -921,6 +933,7 @@ print_internal (obj, printcharfun, escapeflag); } UNGCPRO; + write_char_internal (")", printcharfun); return; } @@ -1041,7 +1054,7 @@ QUIT; - /* Emacs won't print whilst GCing, but an external debugger might */ + /* Emacs won't print while GCing, but an external debugger might */ if (gc_in_progress) return; #ifdef I18N3 @@ -1244,79 +1257,6 @@ print_depth--; } -static void -print_compiled_function_internal (CONST char *start, CONST char *end, - Lisp_Object obj, - Lisp_Object printcharfun, int escapeflag) -{ - /* This function can GC */ - struct Lisp_Compiled_Function *b = - XCOMPILED_FUNCTION (obj); /* GC doesn't relocate */ - int docp = b->flags.documentationp; - int intp = b->flags.interactivep; - struct gcpro gcpro1, gcpro2; - char buf[100]; - GCPRO2 (obj, printcharfun); - - write_c_string (start, printcharfun); -#ifdef COMPILED_FUNCTION_ANNOTATION_HACK - if (!print_readably) - { - Lisp_Object ann = compiled_function_annotation (b); - if (!NILP (ann)) - { - write_c_string ("(from ", printcharfun); - print_internal (ann, printcharfun, 1); - write_c_string (") ", printcharfun); - } - } -#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */ - /* COMPILED_ARGLIST = 0 */ - print_internal (b->arglist, printcharfun, escapeflag); - /* COMPILED_BYTECODE = 1 */ - write_char_internal (" ", printcharfun); - /* we don't really want to see that junk in the bytecode instructions. */ - if (STRINGP (b->bytecodes) && !print_readably) - { - sprintf (buf, "\"...(%ld)\"", (long) XSTRING_LENGTH (b->bytecodes)); - write_c_string (buf, printcharfun); - } - else - print_internal (b->bytecodes, printcharfun, escapeflag); - /* COMPILED_CONSTANTS = 2 */ - write_char_internal (" ", printcharfun); - print_internal (b->constants, printcharfun, escapeflag); - /* COMPILED_STACK_DEPTH = 3 */ - sprintf (buf, " %d", b->maxdepth); - write_c_string (buf, printcharfun); - /* COMPILED_DOC_STRING = 4 */ - if (docp || intp) - { - write_char_internal (" ", printcharfun); - print_internal (compiled_function_documentation (b), printcharfun, - escapeflag); - } - /* COMPILED_INTERACTIVE = 5 */ - if (intp) - { - write_char_internal (" ", printcharfun); - print_internal (compiled_function_interactive (b), printcharfun, - escapeflag); - } - UNGCPRO; - write_c_string (end, printcharfun); -} - -void -print_compiled_function (Lisp_Object obj, Lisp_Object printcharfun, - int escapeflag) -{ - /* This function can GC */ - print_compiled_function_internal (((print_readably) ? "#[" : - "#"), - obj, printcharfun, escapeflag); -} #ifdef LISP_FLOAT_TYPE void @@ -1324,7 +1264,7 @@ { char pigbuf[350]; /* see comments in float_to_string */ - float_to_string (pigbuf, float_data (XFLOAT (obj))); + float_to_string (pigbuf, XFLOAT_DATA (obj)); write_c_string (pigbuf, printcharfun); } #endif /* LISP_FLOAT_TYPE */ @@ -1431,17 +1371,22 @@ XSETSTRING (nameobj, name); for (i = 0; i < size; i++) { - Bufbyte c = string_byte (name, i); - - if (c == '\"' || c == '\\' || c == '\'' || c == ';' || c == '#' || - c == '(' || c == ')' || c == ',' || c =='.' || c == '`' || - c == '[' || c == ']' || c == '?' || c <= 040) + switch (string_byte (name, i)) { + case 0: case 1: case 2: case 3: + case 4: case 5: case 6: case 7: + case 8: case 9: case 10: case 11: + case 12: case 13: case 14: case 15: + case 16: case 17: case 18: case 19: + case 20: case 21: case 22: case 23: + case 24: case 25: case 26: case 27: + case 28: case 29: case 30: case 31: + case ' ': case '\"': case '\\': case '\'': + case ';': case '#' : case '(' : case ')': + case ',': case '.' : case '`' : + case '[': case ']' : case '?' : if (i > last) - { - output_string (printcharfun, 0, nameobj, last, - i - last); - } + output_string (printcharfun, 0, nameobj, last, i - last); write_char_internal ("\\", printcharfun); last = i; } @@ -1614,11 +1559,12 @@ debug_backtrace (void) { /* This function can GC */ - int old_print_readably = print_readably; - int old_print_depth = print_depth; - Lisp_Object old_print_length = Vprint_length; - Lisp_Object old_print_level = Vprint_level; - Lisp_Object old_inhibit_quit = Vinhibit_quit; + int old_print_readably = print_readably; + int old_print_depth = print_depth; + Lisp_Object old_print_length = Vprint_length; + Lisp_Object old_print_level = Vprint_level; + Lisp_Object old_inhibit_quit = Vinhibit_quit; + struct gcpro gcpro1, gcpro2, gcpro3; GCPRO3 (old_print_level, old_print_length, old_inhibit_quit); @@ -1633,15 +1579,18 @@ Vprint_length = make_int (debug_print_length); if (debug_print_level > 0) Vprint_level = make_int (debug_print_level); + Fbacktrace (Qexternal_debugging_output, Qt); stderr_out ("\n"); fflush (stderr); - Vinhibit_quit = old_inhibit_quit; - Vprint_level = old_print_level; - Vprint_length = old_print_length; - print_depth = old_print_depth; + + Vinhibit_quit = old_inhibit_quit; + Vprint_level = old_print_level; + Vprint_length = old_print_length; + print_depth = old_print_depth; print_readably = old_print_readably; print_unbuffered--; + UNGCPRO; } @@ -1662,7 +1611,8 @@ if (COMPILED_FUNCTIONP (*bt->function)) { #if defined(COMPILED_FUNCTION_ANNOTATION_HACK) - Lisp_Object ann = Fcompiled_function_annotation (*bt->function); + Lisp_Object ann = + compiled_function_annotation (XCOMPILED_FUNCTION (*bt->function)); #else Lisp_Object ann = Qnil; #endif diff -r 76b7d63099ad -r 8626e4521993 src/process-nt.c --- a/src/process-nt.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/process-nt.c Mon Aug 13 11:07:10 2007 +0200 @@ -1,4 +1,4 @@ -/* Asynchronous subprocess implemenation for Win32 +/* Asynchronous subprocess implementation for Win32 Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. @@ -45,7 +45,7 @@ /* Bound by winnt.el */ Lisp_Object Qnt_quote_process_args; -/* Implemenation-specific data. Pointed to by Lisp_Process->process_data */ +/* Implementation-specific data. Pointed to by Lisp_Process->process_data */ struct nt_process_data { HANDLE h_process; @@ -382,7 +382,7 @@ } /* - * Initialize XEmacs process implemenation once + * Initialize XEmacs process implementation once */ static void nt_init_process (void) @@ -398,7 +398,7 @@ * object. If this function signals, the caller is responsible for * deleting (and finalizing) the process object. * - * The method must return PID of the new proces, a (positive??? ####) number + * The method must return PID of the new process, a (positive??? ####) number * which fits into Lisp_Int. No return value indicates an error, the method * must signal an error instead. */ @@ -607,7 +607,7 @@ } /* - * Stuff the entire contents of LSTREAM to the process ouptut pipe + * Stuff the entire contents of LSTREAM to the process output pipe */ /* #### If only this function could be somehow merged with @@ -893,7 +893,7 @@ if (nsel > 0) { - /* Check was connnection successful or not */ + /* Check: was connection successful or not? */ tv.tv_usec = 0; nsel = select (0, NULL, NULL, &fdset, &tv); if (nsel > 0) diff -r 76b7d63099ad -r 8626e4521993 src/process-unix.c --- a/src/process-unix.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/process-unix.c Mon Aug 13 11:07:10 2007 +0200 @@ -1,4 +1,4 @@ -/* Asynchronous subprocess implemenation for UNIX +/* Asynchronous subprocess implementation for UNIX Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. @@ -37,11 +37,9 @@ #include "lisp.h" #include "buffer.h" -#include "commands.h" #include "events.h" #include "frame.h" #include "hash.h" -#include "insdel.h" #include "lstream.h" #include "opaque.h" #include "process.h" @@ -62,7 +60,7 @@ /* - * Implemenation-specific data. Pointed to by Lisp_Process->process_data + * Implementation-specific data. Pointed to by Lisp_Process->process_data */ struct unix_process_data @@ -236,7 +234,7 @@ #else /* no PTY_OPEN */ #ifdef IRIS /* Unusual IRIS code */ - *ptyv = open ("/dev/ptc", O_RDWR | O_NDELAY | OPEN_BINARY, 0); + *ptyv = open ("/dev/ptc", O_RDWR | O_NONBLOCK | OPEN_BINARY, 0); if (fd < 0) return -1; if (fstat (fd, &stb) < 0) @@ -250,11 +248,7 @@ } else failed_count = 0; -#ifdef O_NONBLOCK fd = open (pty_name, O_RDWR | O_NONBLOCK | OPEN_BINARY, 0); -#else - fd = open (pty_name, O_RDWR | O_NDELAY | OPEN_BINARY, 0); -#endif #endif /* not IRIS */ #endif /* no PTY_OPEN */ @@ -672,11 +666,11 @@ unix_mark_process_data (struct Lisp_Process *proc, void (*markobj) (Lisp_Object)) { - ((markobj) (UNIX_DATA(proc)->tty_name)); + markobj (UNIX_DATA(proc)->tty_name); } /* - * Initialize XEmacs process implemenation once + * Initialize XEmacs process implementation once */ #ifdef SIGCHLD @@ -708,7 +702,7 @@ * object. If this function signals, the caller is responsible for * deleting (and finalizing) the process object. * - * The method must return PID of the new proces, a (positive??? ####) number + * The method must return PID of the new process, a (positive??? ####) number * which fits into Lisp_Int. No return value indicates an error, the method * must signal an error instead. */ @@ -802,14 +796,6 @@ char **save_environ = environ; #endif -#ifdef EMACS_BTL - /* when performance monitoring is on, turn it off before the vfork(), - as the child has no handler for the signal -- when back in the - parent process, turn it back on if it was really on when you "turned - it off" */ - int logging_on = cadillac_stop_logging (); /* #### rename me */ -#endif - pid = fork (); if (pid == 0) { @@ -925,7 +911,7 @@ will die when we want it to. JV: This needs to be done ALWAYS as we might have inherited a SIG_IGN handling from our parent (nohup) and we are in new - process group. + process group. */ signal (SIGHUP, SIG_DFL); } @@ -942,10 +928,6 @@ child_setup (xforkin, xforkout, xforkout, new_argv, current_dir); } -#ifdef EMACS_BTL - else if (logging_on) - cadillac_start_logging (); /* #### rename me */ -#endif #if !defined(__CYGWIN32__) environ = save_environ; @@ -996,9 +978,7 @@ RETURN_NOT_REACHED (0); } -/* - * Return nonzero if this process is a ToolTalk connection. - */ +/* Return nonzero if this process is a ToolTalk connection. */ static int unix_tooltalk_connection_p (struct Lisp_Process *p) @@ -1006,9 +986,7 @@ return UNIX_DATA(p)->connected_via_filedesc_p; } -/* - * This is called to set process' virtual terminal size - */ +/* This is called to set process' virtual terminal size */ static int unix_set_window_size (struct Lisp_Process* p, int cols, int rows) @@ -1132,7 +1110,7 @@ #endif /* SIGCHLD */ /* - * Stuff the entire contents of LSTREAM to the process ouptut pipe + * Stuff the entire contents of LSTREAM to the process output pipe */ static JMP_BUF send_process_frame; @@ -1180,8 +1158,7 @@ if (writeret < 0) /* This is a real error. Blocking errors are handled specially inside of the filedesc stream. */ - report_file_error ("writing to process", - list1 (vol_proc)); + report_file_error ("writing to process", list1 (proc)); while (Lstream_was_blocked_p (XLSTREAM (p->pipe_outstream))) { /* Buffer is full. Wait, accepting input; @@ -1207,7 +1184,7 @@ p->core_dumped = 0; p->tick++; process_tick++; - deactivate_process (vol_proc); + deactivate_process (*((Lisp_Object *) (&vol_proc))); error ("SIGPIPE raised on process %s; closed it", XSTRING_DATA (p->name)); } @@ -1254,7 +1231,7 @@ * In the lack of this method, only event_stream_delete_stream_pair * is called on both I/O streams of the process. * - * The UNIX version quards this by ignoring possible SIGPIPE. + * The UNIX version guards this by ignoring possible SIGPIPE. */ static USID @@ -1425,7 +1402,7 @@ /* * Canonicalize host name HOST, and return its canonical form * - * The default implemenation just takes HOST for a canonical name. + * The default implementation just takes HOST for a canonical name. */ #ifdef HAVE_SOCKETS @@ -1575,7 +1552,7 @@ TCP case, the multicast connection will be seen as a sub-process, Some notes: - - Normaly, we should use sendto and recvfrom with non connected + - Normally, we should use sendto and recvfrom with non connected sockets. The current code doesn't allow us to do this. In the future, it would be a good idea to extend the process data structure in order to deal properly with the different types network connections. @@ -1656,7 +1633,7 @@ /* Socket configuration for writing ----------------------- */ - /* Normaly, there's no 'connect' in multicast, since we use preferentialy + /* Normally, there's no 'connect' in multicast, since we prefer to use 'sendto' and 'recvfrom'. However, in order to handle this connection in the process-like way it is done for TCP, we must be able to use 'write' instead of 'sendto'. Consequently, we 'connect' this socket. */ diff -r 76b7d63099ad -r 8626e4521993 src/process.c --- a/src/process.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/process.c Mon Aug 13 11:07:10 2007 +0200 @@ -46,7 +46,6 @@ #include "opaque.h" #include "process.h" #include "procimpl.h" -#include "sysdep.h" #include "window.h" #ifdef FILE_CODING #include "file-coding.h" @@ -100,9 +99,9 @@ /* Nonzero means delete a process right away if it exits. */ int delete_exited_processes; -/* Hashtable which maps USIDs as returned by create_stream_pair_cb to +/* Hash table which maps USIDs as returned by create_stream_pair_cb to process objects. Processes are not GC-protected through this! */ -c_hashtable usid_to_process; +struct hash_table *usid_to_process; /* List of process objects. */ Lisp_Object Vprocess_list; @@ -114,18 +113,18 @@ { struct Lisp_Process *proc = XPROCESS (obj); MAYBE_PROCMETH (mark_process_data, (proc, markobj)); - ((markobj) (proc->name)); - ((markobj) (proc->command)); - ((markobj) (proc->filter)); - ((markobj) (proc->sentinel)); - ((markobj) (proc->buffer)); - ((markobj) (proc->mark)); - ((markobj) (proc->pid)); - ((markobj) (proc->pipe_instream)); - ((markobj) (proc->pipe_outstream)); + markobj (proc->name); + markobj (proc->command); + markobj (proc->filter); + markobj (proc->sentinel); + markobj (proc->buffer); + markobj (proc->mark); + markobj (proc->pid); + markobj (proc->pipe_instream); + markobj (proc->pipe_outstream); #ifdef FILE_CODING - ((markobj) (proc->coding_instream)); - ((markobj) (proc->coding_outstream)); + markobj (proc->coding_instream); + markobj (proc->coding_outstream); #endif return proc->status_symbol; } @@ -192,7 +191,7 @@ /************************************************************************/ /* Under FILE_CODING, this function returns low-level streams, connected - directrly to the child process, rather than en/decoding FILE_CODING + directly to the child process, rather than en/decoding FILE_CODING streams */ void get_process_streams (struct Lisp_Process *p, @@ -357,7 +356,7 @@ else { /* #### This was commented out. Although, simple - (kill-process 7 "qqq") resulted in a falat error. - kkm */ + (kill-process 7 "qqq") resulted in a fatal error. - kkm */ CHECK_PROCESS (obj); proc = obj; } @@ -643,8 +642,8 @@ functions must then go to lisp and provide a suitable list for the generalized connection function. - Both UNIX ans Win32 support BSD sockets, and there are many extensions - availalble (Sockets 2 spec). + Both UNIX and Win32 support BSD sockets, and there are many extensions + available (Sockets 2 spec). A todo is define a consistent set of properties abstracting a network connection. -kkm @@ -897,7 +896,7 @@ old_zv += nchars; #if 0 - /* This screws up intial display of the window. jla */ + /* This screws up initial display of the window. jla */ /* Insert before markers in case we are inserting where the buffer's mark is, and the user's next command is Meta-y. */ @@ -1743,7 +1742,7 @@ handle_signal (SIGUNUSED); #endif #ifdef SIGDANGER - handle_signal (SIGDANGER); + handle_signal (SIGDANGER); /* AIX */ #endif #ifdef SIGMSG handle_signal (SIGMSG); @@ -1946,7 +1945,11 @@ MAYBE_PROCMETH (init_process, ()); Vprocess_list = Qnil; - usid_to_process = make_hashtable (32); + + if (usid_to_process) + clrhash (usid_to_process); + else + usid_to_process = make_hash_table (32); } #if 0 @@ -2054,11 +2057,11 @@ Vprocess_connection_type = Qt; DEFVAR_BOOL ("windowed-process-io", &windowed_process_io /* -Enables input/ouptut on standard handles of a windowed process. +Enables input/output on standard handles of a windowed process. When this variable is nil (the default), XEmacs does not attempt to read standard output handle of a windowed process. Instead, the process is immediately marked as exited immediately upon successful launching. This is -done because normal windowed processes do not use stadnard I/O, as they are +done because normal windowed processes do not use standard I/O, as they are not connected to any console. When launching a specially crafted windowed process, which expects to be diff -r 76b7d63099ad -r 8626e4521993 src/procimpl.h --- a/src/procimpl.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/procimpl.h Mon Aug 13 11:07:10 2007 +0200 @@ -29,7 +29,7 @@ /* * Structure which keeps methods of the process implementation. - * There is only one object of this class exists in a perticular + * There is only one object of this class exists in a particular * XEmacs implementation. */ @@ -163,7 +163,7 @@ extern Lisp_Object Vprocess_connection_type; extern Lisp_Object Vprocess_list; -extern c_hashtable usid_to_process; +extern struct hash_table *usid_to_process; extern volatile int process_tick; diff -r 76b7d63099ad -r 8626e4521993 src/profile.c --- a/src/profile.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/profile.c Mon Aug 13 11:07:10 2007 +0200 @@ -24,6 +24,7 @@ #include "backtrace.h" #include "bytecode.h" +#include "elhash.h" #include "hash.h" #include "syssignal.h" @@ -38,25 +39,25 @@ (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 */ + 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 */ -c_hashtable big_profile_table; +struct hash_table *big_profile_table; Lisp_Object Vcall_count_profile_table; int default_profiling_interval; @@ -78,15 +79,16 @@ enough to catch us while we're already in there. */ static volatile int inside_profiling; -/* Increase the value of OBJ in Vcall_count_profile_table hashtable. - If hashtable is nil, create it first. */ +/* Increase the value of OBJ in Vcall_count_profile_table hash table. + If the hash table is nil, create it first. */ void profile_increase_call_count (Lisp_Object obj) { Lisp_Object count; if (NILP (Vcall_count_profile_table)) - Vcall_count_profile_table = Fmake_hashtable (make_int (100), Qeq); + Vcall_count_profile_table = + make_lisp_hash_table (100, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); count = Fgethash (obj, Vcall_count_profile_table, Qzero); if (!INTP (count)) @@ -117,8 +119,10 @@ { fun = *backtrace_list->function; - if (!GC_SYMBOLP (fun) && !GC_COMPILED_FUNCTIONP (fun)) - fun = QSunknown; + if (!GC_SYMBOLP (fun) && + !GC_COMPILED_FUNCTIONP (fun) && + !GC_SUBRP (fun)) + fun = QSunknown; } else fun = QSprocessing_events_at_top_level; @@ -163,12 +167,13 @@ struct itimerval foo; /* #### The hash code can safely be called from a signal handler - except when it has to grow the hashtable. In this case, it calls - realloc(), which is not (in general) re-entrant. We just be + except when it has to grow the hash table. In this case, it calls + realloc(), which is not (in general) re-entrant. We'll just be sleazy and make the table large enough that it (hopefully) won't need to be realloc()ed. */ if (!big_profile_table) - big_profile_table = make_hashtable (10000); + big_profile_table = make_hash_table (10000); + if (NILP (microsecs)) msecs = default_profiling_interval; else @@ -301,7 +306,7 @@ clrhash (big_profile_table); inside_profiling = 0; } - if (!NILP(Vcall_count_profile_table)) + if (!NILP (Vcall_count_profile_table)) Fclrhash (Vcall_count_profile_table); return Qnil; } @@ -328,7 +333,7 @@ vars_of_profile (void) { DEFVAR_INT ("default-profiling-interval", &default_profiling_interval /* -Default time in microseconds between profiling queries. +Default CPU time in microseconds between profiling sampling. Used when the argument to `start-profiling' is nil or omitted. Note that the time in question is CPU time (when the program is executing or the kernel is executing on behalf of the program) and not real time. @@ -337,8 +342,8 @@ DEFVAR_LISP ("call-count-profile-table", &Vcall_count_profile_table /* The table where call-count information is stored by the profiling primitives. -This is a hashtable whose keys are funcallable objects, and whose - values are their call counts (integers). +This is a hash table whose keys are funcallable objects, and whose +values are their call counts (integers). */ ); Vcall_count_profile_table = Qnil; diff -r 76b7d63099ad -r 8626e4521993 src/puresize.h --- a/src/puresize.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/puresize.h Mon Aug 13 11:07:10 2007 +0200 @@ -163,7 +163,10 @@ #endif /* !RAW_PURESIZE */ -size_t get_PURESIZE (void); +# include +#define PURESIZE ((RAW_PURESIZE) + (PURESIZE_ADJUSTMENT)) +#define get_PURESIZE() PURESIZE + extern EMACS_INT pure[]; #endif /* PURESIZE_H */ diff -r 76b7d63099ad -r 8626e4521993 src/ralloc.c --- a/src/ralloc.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/ralloc.c Mon Aug 13 11:07:10 2007 +0200 @@ -1409,12 +1409,12 @@ static int DEV_ZERO_FD = -1; -/* We actually need a datastructure that can be usefully structured +/* We actually need a data structure that can be usefully structured based on the VM address, and allows an ~O(1) lookup on an arbitrary - address, ie a hash-table. Maybe the XEmacs hash table can be - coaxed enough. At the moment, we use lookup on a hash-table to + address, i.e. a hash table. Maybe the XEmacs hash table can be + coaxed enough. At the moment, we use lookup on a hash table to decide whether to do an O(n) search on the malloced block list. - Addresses are hashed to a bucket modulo MHASH_PRIME */ + Addresses are hashed to a bucket modulo MHASH_PRIME. */ /* We settle for a standard doubly-linked-list. The dynarr type isn't diff -r 76b7d63099ad -r 8626e4521993 src/rangetab.c --- a/src/rangetab.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/rangetab.c Mon Aug 13 11:07:10 2007 +0200 @@ -47,7 +47,7 @@ int i; for (i = 0; i < Dynarr_length (rt->entries); i++) - (markobj) (Dynarr_at (rt->entries, i).val); + markobj (Dynarr_at (rt->entries, i).val); return Qnil; } @@ -242,15 +242,13 @@ (pos, table, default_)) { struct Lisp_Range_Table *rt; - EMACS_INT po; CHECK_RANGE_TABLE (table); rt = XRANGE_TABLE (table); CHECK_INT_COERCE_CHAR (pos); - po = XINT (pos); - return get_range_table (po, Dynarr_length (rt->entries), + return get_range_table (XINT (pos), Dynarr_length (rt->entries), Dynarr_atp (rt->entries, 0), default_); } diff -r 76b7d63099ad -r 8626e4521993 src/realpath.c --- a/src/realpath.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/realpath.c Mon Aug 13 11:07:10 2007 +0200 @@ -87,11 +87,11 @@ /* ** In NT we have two different cases: (1) the path name begins ** with a drive letter, e.g., "C:"; and (2) the path name begins - ** with just a slash, which roots to the current drive. In the + ** with just a slash, which roots to the current drive. In the ** first case we are going to leave things alone, in the second ** case we will prepend the drive letter to the given path. ** Note: So far in testing, I'm only seeing case #1, even though - ** I've tried to get the other cases to happen. + ** I've tried to get the other cases to happen. ** August Hill, 31 Aug 1997. ** ** Check for a driver letter...C:/... diff -r 76b7d63099ad -r 8626e4521993 src/redisplay-msw.c --- a/src/redisplay-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/redisplay-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -54,7 +54,7 @@ #define MSWINDOWS_EOL_CURSOR_WIDTH 5 /* - * Random forward delarations + * Random forward declarations */ static void mswindows_update_dc (HDC hdc, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, Lisp_Object bg_pmap); @@ -1087,7 +1087,7 @@ Given a display line, a block number for that start line, output all runes between start and end in the specified display block. - Ripped off with mininmal thought from the corresponding X routine. + Ripped off with minimal thought from the corresponding X routine. ****************************************************************************/ static void mswindows_output_display_block (struct window *w, struct display_line *dl, int block, @@ -1346,7 +1346,7 @@ /* Draw a shadow around the divider */ if (shadow != 0) { - /* #### This will be fixed to support arbitrary thichkness */ + /* #### This will be fixed to support arbitrary thickness */ InflateRect (&rect, abs_shadow, abs_shadow); DrawEdge (FRAME_MSWINDOWS_DC (f), &rect, shadow > 0 ? EDGE_RAISED : EDGE_SUNKEN, BF_RECT); diff -r 76b7d63099ad -r 8626e4521993 src/redisplay-output.c --- a/src/redisplay-output.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/redisplay-output.c Mon Aug 13 11:07:10 2007 +0200 @@ -28,7 +28,6 @@ #include #include "lisp.h" -#include "debug.h" #include "buffer.h" #include "window.h" @@ -38,8 +37,6 @@ #include "redisplay.h" #include "faces.h" -#include "sysdep.h" - static int compare_runes (struct window *w, struct rune *crb, struct rune *drb); static void redraw_cursor_in_window (struct window *w, @@ -538,7 +535,7 @@ a TEXT block. */ if (ddl->modeline) { - /* The shadow thickness check is necesssary if only the sign of + /* The shadow thickness check is necessary if only the sign of the size changed. */ if (cdba && !w->shadow_thickness_changed) { diff -r 76b7d63099ad -r 8626e4521993 src/redisplay-tty.c --- a/src/redisplay-tty.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/redisplay-tty.c Mon Aug 13 11:07:10 2007 +0200 @@ -289,7 +289,7 @@ elt++; } } - /* #### RUNE_HLINE is actualy a little more complicated than this + /* #### RUNE_HLINE is actually a little more complicated than this but at the moment it is only used to draw a turned off modeline and this will suffice for that. */ else if (rb->type == RUNE_BLANK || rb->type == RUNE_HLINE) diff -r 76b7d63099ad -r 8626e4521993 src/redisplay-x.c --- a/src/redisplay-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/redisplay-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -929,7 +929,7 @@ { /* Ensure the gray bitmap exists */ if (DEVICE_X_GRAY_PIXMAP (d) == None) - DEVICE_X_GRAY_PIXMAP (d) = + DEVICE_X_GRAY_PIXMAP (d) = XCreateBitmapFromData (dpy, x_win, (char *)gray_bits, gray_width, gray_height); @@ -1410,7 +1410,7 @@ unsigned long mask; int x, y1, y2, width, shadow_thickness, spacing, line_width; face_index div_face = get_builtin_face_cache_index (w, Vvertical_divider_face); - + width = window_divider_width (w); shadow_thickness = XINT (w->vertical_divider_shadow_thickness); spacing = XINT (w->vertical_divider_spacing); @@ -1418,20 +1418,20 @@ x = WINDOW_RIGHT (w) - width; y1 = WINDOW_TOP (w); y2 = WINDOW_BOTTOM (w); - + memset (&gcv, ~0, sizeof (XGCValues)); - + tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); - + /* First, get the GC's. */ top_shadow_pixel = tmp_color.pixel; bottom_shadow_pixel = tmp_color.pixel; background_pixel = tmp_color.pixel; - + x_generate_shadow_pixels (f, &top_shadow_pixel, &bottom_shadow_pixel, background_pixel, ef->core.background_pixel); - + tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); gcv.background = tmp_color.pixel; @@ -1439,11 +1439,11 @@ mask = GCForeground | GCBackground | GCGraphicsExposures; /* If we can't distinguish one of the shadows (the color is the same as the - background), it's better to use a pixmap to generate a dithrered gray. */ + background), it's better to use a pixmap to generate a dithered gray. */ if (top_shadow_pixel == background_pixel || bottom_shadow_pixel == background_pixel) use_pixmap = 1; - + if (use_pixmap) { if (DEVICE_X_GRAY_PIXMAP (d) == None) @@ -1452,7 +1452,7 @@ XCreatePixmapFromBitmapData (dpy, x_win, (char *) gray_bits, gray_width, gray_height, 1, 0, 1); } - + tmp_pixel = WINDOW_FACE_CACHEL_BACKGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); gcv.foreground = tmp_color.pixel; @@ -1461,11 +1461,11 @@ gcv.stipple = DEVICE_X_GRAY_PIXMAP (d); top_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, (mask | GCStipple | GCFillStyle)); - + tmp_pixel = WINDOW_FACE_CACHEL_FOREGROUND (w, div_face); tmp_color = COLOR_INSTANCE_X_COLOR (XCOLOR_INSTANCE (tmp_pixel)); bottom_shadow_pixel = tmp_color.pixel; - + flip_gcs = (bottom_shadow_pixel == WhitePixelOfScreen (DefaultScreenOfDisplay (dpy))); } @@ -1474,20 +1474,20 @@ gcv.foreground = top_shadow_pixel; top_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask); } - + gcv.foreground = bottom_shadow_pixel; bottom_shadow_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask); - + if (use_pixmap && flip_gcs) { GC tmp_gc = bottom_shadow_gc; bottom_shadow_gc = top_shadow_gc; top_shadow_gc = tmp_gc; } - + gcv.foreground = background_pixel; background_gc = gc_cache_lookup (DEVICE_X_GC_CACHE (d), &gcv, mask); - + /* possibly revert the GC's in case the shadow thickness is < 0. This will give a depressed look to the divider */ if (shadow_thickness < 0) @@ -1497,8 +1497,8 @@ temp = top_shadow_gc; top_shadow_gc = bottom_shadow_gc; bottom_shadow_gc = temp; - - /* better avoid a Bad Adress XLib error ;-) */ + + /* better avoid a Bad Address XLib error ;-) */ shadow_thickness = - shadow_thickness; } @@ -1508,12 +1508,12 @@ XClearArea (dpy, x_win, x, y1, width, y2 - y1, False); /* Draw the divider line. */ - XFillRectangle (dpy, x_win, background_gc, + XFillRectangle (dpy, x_win, background_gc, x + spacing + shadow_thickness, y1, line_width, y2 - y1); - + /* Draw the shadows around the divider line */ - x_output_shadows (f, x + spacing, y1, + x_output_shadows (f, x + spacing, y1, width - 2 * spacing, y2 - y1, top_shadow_gc, bottom_shadow_gc, background_gc, shadow_thickness); @@ -1678,7 +1678,7 @@ x_output_shadows Draw a shadow around the given area using the given GC's. It is the - callers responsibility to ste the GC's appropriately. + callers responsibility to set the GC's appropriately. ****************************************************************************/ void x_output_shadows (struct frame *f, int x, int y, int width, int height, diff -r 76b7d63099ad -r 8626e4521993 src/redisplay.c --- a/src/redisplay.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/redisplay.c Mon Aug 13 11:07:10 2007 +0200 @@ -46,6 +46,7 @@ #include "commands.h" #include "debug.h" #include "device.h" +#include "elhash.h" #include "extents.h" #include "faces.h" #include "frame.h" @@ -1805,7 +1806,7 @@ like: a) A 256-entry vector, for backward compatibility - b) Some sort of hashtable, mapping characters to values + b) Some sort of hash table, mapping characters to values c) A list that specifies a range of values and the mapping to provide for those values. @@ -2338,7 +2339,7 @@ { /* If data.start_col_enabled is still true, then the window is scrolled far enough so that nothing on this line is visible. - We need to stick a trunctation glyph at the beginning of the + We need to stick a truncation glyph at the beginning of the line in that case unless the line is completely blank. */ if (data.bi_start_col_enabled) { @@ -2871,7 +2872,7 @@ they should start. The inside margin glyphs get whatever space is left after the whitespace glyphs have been displayed. These are tricky to calculate since if we decide to use the overflow - area we basicaly have to start over. So for these we build up a + area we basically have to start over. So for these we build up a list of just the inside margin glyphs and manipulate it to determine the needed info. */ { @@ -3000,7 +3001,7 @@ struct glyph_block *gb = Dynarr_atp (dl->left_glyphs, elt); if (NILP (gb->extent)) - abort (); /* these should have beeb handled in add_glyph_rune */ + abort (); /* these should have been handled in add_glyph_rune */ if (extent_begin_glyph_layout (XEXTENT (gb->extent)) == GL_OUTSIDE_MARGIN) @@ -3190,7 +3191,7 @@ they should start. The inside margin glyphs get whatever space is left after the whitespace glyphs have been displayed. These are tricky to calculate since if we decide to use the overflow - area we basicaly have to start over. So for these we build up a + area we basically have to start over. So for these we build up a list of just the inside margin glyphs and manipulate it to determine the needed info. */ { @@ -3313,7 +3314,7 @@ struct glyph_block *gb = Dynarr_atp (dl->right_glyphs, elt); if (NILP (gb->extent)) - abort (); /* these should have beeb handled in add_glyph_rune */ + abort (); /* these should have been handled in add_glyph_rune */ if (extent_end_glyph_layout (XEXTENT (gb->extent)) == GL_OUTSIDE_MARGIN) { @@ -3524,7 +3525,7 @@ MODELINE_INDEX, min_pixpos, max_pixpos, type); /* The modeline is at the bottom of the gutters. We have to wait to - set this until we've generated teh modeline in order to account + set this until we've generated the modeline in order to account for any embedded faces. */ dl->ypos = WINDOW_BOTTOM (w) - dl->descent - ypos_adj; } @@ -5049,7 +5050,7 @@ Fset_marker (w->pointm[DESIRED_DISP], make_int (pointm), the_buffer); - /* #### BUFU amounts of overkil just to get the cursor + /* #### BUFU amounts of overkill just to get the cursor location marked properly. FIX ME FIX ME FIX ME */ regenerate_window (w, startp, pointm, DESIRED_DISP); } @@ -5241,7 +5242,7 @@ redisplay_output_window (w); /* * If we just displayed the echo area, the line start cache is - * no longer valid, because the minibuffer window is assocaited + * no longer valid, because the minibuffer window is associated * with the window now. */ if (echo_active) @@ -5354,13 +5355,13 @@ change_frame_size (f, f->new_height, f->new_width, 0); /* If frame size might need to be changed, due to changed size - of toolbars, scroolabrs etc, change it now */ + of toolbars, scrollbars etc, change it now */ if (f->size_slipped) { adjust_frame_size (f); assert (!f->size_slipped); } - + /* The menubar, toolbar, and icon updates must be done before hold_frame_size_changes is called and we are officially 'in_display'. They may eval lisp code which may call Fsignal. @@ -5703,9 +5704,9 @@ { struct device *d = XDEVICE (XFRAME (w->frame)->device); struct buffer *b = XBUFFER (w->buffer); - /* Be careful in the order of these tests. The first clasue will + /* Be careful in the order of these tests. The first clause will fail if DEVICE_SELECTED_FRAME == Qnil (since w->frame cannot be). - This can occur when the frame title is computed really early */ + This can occur when the frame title is computed really early */ Bufpos pos = ((EQ(DEVICE_SELECTED_FRAME(d), w->frame) && (w == XWINDOW (FRAME_SELECTED_WINDOW (device_selected_frame(d)))) && @@ -6089,8 +6090,10 @@ for (; gb < gb_last; gb++) { - if (!NILP (gb->glyph)) ((markobj) (gb->glyph)); - if (!NILP (gb->extent)) ((markobj) (gb->extent)); + if (!NILP (gb->glyph)) + markobj (gb->glyph); + if (!NILP (gb->extent)) + markobj (gb->extent); } } } @@ -6118,9 +6121,9 @@ if (r->type == RUNE_DGLYPH) { if (!NILP (r->object.dglyph.glyph)) - ((markobj) (r->object.dglyph.glyph)); + markobj (r->object.dglyph.glyph); if (!NILP (r->object.dglyph.extent)) - ((markobj) (r->object.dglyph.extent)); + markobj (r->object.dglyph.extent); } } } @@ -6264,7 +6267,7 @@ size changes can cause text shifting. However, the extent covering the region is constantly having its face set and priority altered by the mouse code. This means that the line - start cache is constanty being invalidated. This is bad + start cache is constantly being invalidated. This is bad since the mouse code also triggers heavy usage of the cache. Since it is an unlikely that f->extents being changed indicates that the cache really needs to be updated and if it @@ -7064,7 +7067,7 @@ /* * Handle invisible text properly: - * If the last line we're inserting has the same end as the + * If the last line we're inserting has the same end as the * line before which it will be added, merge the two lines. */ if (Dynarr_length (cache) && @@ -7300,7 +7303,7 @@ d->pixel_to_glyph_cache.obj1 = *obj1; \ d->pixel_to_glyph_cache.obj2 = *obj2; \ d->pixel_to_glyph_cache.retval = position; \ - RETURN__ position; \ + RETURN_SANS_WARNINGS position; \ } while (0) /* Given x and y coordinates in pixels relative to a frame, return @@ -8059,40 +8062,29 @@ { if (WINDOWP (locale)) { - struct frame *f = XFRAME (WINDOW_FRAME (XWINDOW (locale))); - MARK_FRAME_GLYPHS_CHANGED (f); + MARK_FRAME_GLYPHS_CHANGED (XFRAME (WINDOW_FRAME (XWINDOW (locale)))); } else if (FRAMEP (locale)) { - struct frame *f = XFRAME (locale); - MARK_FRAME_GLYPHS_CHANGED (f); + MARK_FRAME_GLYPHS_CHANGED (XFRAME (locale)); } else if (DEVICEP (locale)) { Lisp_Object frmcons; DEVICE_FRAME_LOOP (frmcons, XDEVICE (locale)) - { - struct frame *f = XFRAME (XCAR (frmcons)); - MARK_FRAME_GLYPHS_CHANGED (f); - } + MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons))); } else if (CONSOLEP (locale)) { Lisp_Object frmcons, devcons; CONSOLE_FRAME_LOOP_NO_BREAK (frmcons, devcons, XCONSOLE (locale)) - { - struct frame *f = XFRAME (XCAR (frmcons)); - MARK_FRAME_GLYPHS_CHANGED (f); - } + MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons))); } else /* global or buffer */ { Lisp_Object frmcons, devcons, concons; FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) - { - struct frame *f = XFRAME (XCAR (frmcons)); - MARK_FRAME_GLYPHS_CHANGED (f); - } + MARK_FRAME_GLYPHS_CHANGED (XFRAME (XCAR (frmcons))); } } @@ -8302,7 +8294,7 @@ Minimum pixel height for clipped bottom display line. A clipped line shorter than this won't be displayed. */ , - redisplay_variable_changed); + redisplay_variable_changed); vertical_clip = 5; DEFVAR_INT_MAGIC ("pixel-horizontal-clip-threshold", &horizontal_clip /* @@ -8310,7 +8302,7 @@ Clipped glyphs shorter than this won't be displayed. Only pixmap glyph instances are currently allowed to be clipped. */ , - redisplay_variable_changed); + redisplay_variable_changed); horizontal_clip = 5; DEFVAR_LISP ("global-mode-string", &Vglobal_mode_string /* @@ -8322,13 +8314,14 @@ Marker for where to display an arrow on top of the buffer text. This must be the beginning of a line in order to work. See also `overlay-arrow-string'. -*/ , redisplay_variable_changed); +*/ , + redisplay_variable_changed); Voverlay_arrow_position = Qnil; DEFVAR_LISP_MAGIC ("overlay-arrow-string", &Voverlay_arrow_string /* String to display as an arrow. See also `overlay-arrow-position'. */ , - redisplay_variable_changed); + redisplay_variable_changed); Voverlay_arrow_string = Qnil; DEFVAR_INT ("scroll-step", &scroll_step /* @@ -8347,7 +8340,7 @@ &truncate_partial_width_windows /* *Non-nil means truncate lines in all windows less than full frame wide. */ , - redisplay_variable_changed); + redisplay_variable_changed); truncate_partial_width_windows = 1; DEFVAR_BOOL ("visible-bell", &visible_bell /* diff -r 76b7d63099ad -r 8626e4521993 src/redisplay.h --- a/src/redisplay.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/redisplay.h Mon Aug 13 11:07:10 2007 +0200 @@ -139,7 +139,7 @@ /* CHAR */ struct { - Emchar ch; /* Cbaracter of this rune. */ + Emchar ch; /* Character of this rune. */ } chr; /* HLINE */ @@ -256,7 +256,7 @@ int cursor_elt; /* rune block of TEXT display block cursor is at or -1 */ char used_prop_data; /* can't incrementally update if line - used propogation data */ + used propagation data */ layout_bounds bounds; /* line boundary positions */ @@ -389,23 +389,23 @@ if each has already been called and don't bother doing most of the work if it is currently set. */ -#define MARK_TYPE_CHANGED(object) do { \ - if (!object##_changed_set) { \ - Lisp_Object _devcons_, _concons_; \ - DEVICE_LOOP_NO_BREAK (_devcons_, _concons_) \ - { \ - Lisp_Object _frmcons_; \ - struct device *_d_ = XDEVICE (XCAR (_devcons_)); \ - DEVICE_FRAME_LOOP (_frmcons_, _d_) \ - { \ - struct frame *_f_ = XFRAME (XCAR (_frmcons_)); \ - _f_->object##_changed = 1; \ - _f_->modiff++; \ - } \ - _d_->object##_changed = 1; \ - } \ - object##_changed = 1; \ - object##_changed_set = 1; } \ +#define MARK_TYPE_CHANGED(object) do { \ + if (!object##_changed_set) { \ + Lisp_Object MTC_devcons, MTC_concons; \ + DEVICE_LOOP_NO_BREAK (MTC_devcons, MTC_concons) \ + { \ + Lisp_Object MTC_frmcons; \ + struct device *MTC_d = XDEVICE (XCAR (MTC_devcons)); \ + DEVICE_FRAME_LOOP (MTC_frmcons, MTC_d) \ + { \ + struct frame *MTC_f = XFRAME (XCAR (MTC_frmcons)); \ + MTC_f->object##_changed = 1; \ + MTC_f->modiff++; \ + } \ + MTC_d->object##_changed = 1; \ + } \ + object##_changed = 1; \ + object##_changed_set = 1; } \ } while (0) #define MARK_BUFFERS_CHANGED MARK_TYPE_CHANGED (buffers) @@ -420,17 +420,17 @@ /* Anytime a console, device or frame is added or deleted we need to reset these flags. */ -#define RESET_CHANGED_SET_FLAGS \ - do { \ - buffers_changed_set = 0; \ - clip_changed_set = 0; \ - extents_changed_set = 0; \ - icon_changed_set = 0; \ - menubar_changed_set = 0; \ - modeline_changed_set = 0; \ - point_changed_set = 0; \ - toolbar_changed_set = 0; \ - glyphs_changed_set = 0; \ +#define RESET_CHANGED_SET_FLAGS \ + do { \ + buffers_changed_set = 0; \ + clip_changed_set = 0; \ + extents_changed_set = 0; \ + icon_changed_set = 0; \ + menubar_changed_set = 0; \ + modeline_changed_set = 0; \ + point_changed_set = 0; \ + toolbar_changed_set = 0; \ + glyphs_changed_set = 0; \ } while (0) @@ -438,7 +438,7 @@ /* redisplay global variables */ /*************************************************************************/ -/* redisplay structre used by various utility routines. */ +/* redisplay structure used by various utility routines. */ extern display_line_dynarr *cmotion_display_lines; /* Nonzero means truncate lines in all windows less wide than the frame. */ @@ -473,7 +473,7 @@ extern int display_arg; /* Type of display specified. Defined in emacs.c. */ -extern char *display_use; +extern CONST char *display_use; /* Nonzero means reading single-character input with prompt so put cursor on minibuffer after the prompt. */ diff -r 76b7d63099ad -r 8626e4521993 src/regex.c --- a/src/regex.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/regex.c Mon Aug 13 11:07:10 2007 +0200 @@ -1284,14 +1284,14 @@ DEBUG_PRINT2 (" Pushing reg: %d\n", this_reg); \ DEBUG_STATEMENT (num_regs_pushed++); \ \ - DEBUG_PRINT2 (" start: 0x%p\n", regstart[this_reg]); \ + DEBUG_PRINT2 (" start: 0x%lx\n", (long) regstart[this_reg]); \ PUSH_FAILURE_POINTER (regstart[this_reg]); \ \ - DEBUG_PRINT2 (" end: 0x%p\n", regend[this_reg]); \ + DEBUG_PRINT2 (" end: 0x%lx\n", (long) regend[this_reg]); \ PUSH_FAILURE_POINTER (regend[this_reg]); \ \ DEBUG_PRINT2 (" info: 0x%lx\n ", \ - * (unsigned long *) (®_info[this_reg])); \ + * (long *) (®_info[this_reg])); \ DEBUG_PRINT2 (" match_null=%d", \ REG_MATCH_NULL_STRING_P (reg_info[this_reg])); \ DEBUG_PRINT2 (" active=%d", IS_ACTIVE (reg_info[this_reg])); \ @@ -1309,11 +1309,11 @@ DEBUG_PRINT2 (" Pushing high active reg: %d\n", highest_active_reg);\ PUSH_FAILURE_INT (highest_active_reg); \ \ - DEBUG_PRINT2 (" Pushing pattern 0x%p: ", pattern_place); \ + DEBUG_PRINT2 (" Pushing pattern 0x%lx: ", (long) pattern_place); \ DEBUG_PRINT_COMPILED_PATTERN (bufp, pattern_place, pend); \ PUSH_FAILURE_POINTER (pattern_place); \ \ - DEBUG_PRINT2 (" Pushing string 0x%p: `", string_place); \ + DEBUG_PRINT2 (" Pushing string 0x%lx: `", (long) string_place); \ DEBUG_PRINT_DOUBLE_STRING (string_place, string1, size1, string2, \ size2); \ DEBUG_PRINT1 ("'\n"); \ @@ -1387,12 +1387,12 @@ if (string_temp != NULL) \ str = (CONST char *) string_temp; \ \ - DEBUG_PRINT2 (" Popping string 0x%p: `", str); \ + DEBUG_PRINT2 (" Popping string 0x%lx: `", (long) str); \ DEBUG_PRINT_DOUBLE_STRING (str, string1, size1, string2, size2); \ DEBUG_PRINT1 ("'\n"); \ \ pat = (unsigned char *) POP_FAILURE_POINTER (); \ - DEBUG_PRINT2 (" Popping pattern 0x%p: ", pat); \ + DEBUG_PRINT2 (" Popping pattern 0x%lx: ", (long) pat); \ DEBUG_PRINT_COMPILED_PATTERN (bufp, pat, pend); \ \ /* Restore register info. */ \ @@ -1408,13 +1408,13 @@ \ reg_info[this_reg].word = POP_FAILURE_ELT (); \ DEBUG_PRINT2 (" info: 0x%lx\n", \ - * (unsigned long *) ®_info[this_reg]); \ + * (long *) ®_info[this_reg]); \ \ regend[this_reg] = (CONST char *) POP_FAILURE_POINTER (); \ - DEBUG_PRINT2 (" end: 0x%p\n", regend[this_reg]); \ + DEBUG_PRINT2 (" end: 0x%lx\n", (long) regend[this_reg]); \ \ regstart[this_reg] = (CONST char *) POP_FAILURE_POINTER (); \ - DEBUG_PRINT2 (" start: 0x%p\n", regstart[this_reg]); \ + DEBUG_PRINT2 (" start: 0x%lx\n", (long) regstart[this_reg]); \ } \ \ set_regs_matched_done = 0; \ @@ -3315,7 +3315,7 @@ return syntax & RE_NO_EMPTY_RANGES ? REG_ERANGE : REG_NOERROR; /* Can't have ranges spanning different charsets, except maybe for - ranges entirely witin the first 256 chars. */ + ranges entirely within the first 256 chars. */ if ((range_start >= 0x100 || range_end >= 0x100) && CHAR_LEADING_BYTE (range_start) != @@ -4473,7 +4473,7 @@ fails at this starting point in the input data. */ for (;;) { - DEBUG_PRINT2 ("\n0x%p: ", p); + DEBUG_PRINT2 ("\n0x%lx: ", (long) p); #ifdef emacs /* XEmacs added, w/removal of immediate_quit */ if (!no_quit_in_re_search) QUIT; @@ -5084,7 +5084,7 @@ DEBUG_PRINT1 ("EXECUTING on_failure_keep_string_jump"); EXTRACT_NUMBER_AND_INCR (mcnt, p); - DEBUG_PRINT3 (" %d (to 0x%p):\n", mcnt, p + mcnt); + DEBUG_PRINT3 (" %d (to 0x%lx):\n", mcnt, (long) (p + mcnt)); PUSH_FAILURE_POINT (p + mcnt, (char *) 0, -2); break; @@ -5107,7 +5107,7 @@ DEBUG_PRINT1 ("EXECUTING on_failure_jump"); EXTRACT_NUMBER_AND_INCR (mcnt, p); - DEBUG_PRINT3 (" %d (to 0x%p)", mcnt, p + mcnt); + DEBUG_PRINT3 (" %d (to 0x%lx)", mcnt, (long) (p + mcnt)); /* If this on_failure_jump comes right before a group (i.e., the original * applied to a group), save the information @@ -5322,7 +5322,7 @@ EXTRACT_NUMBER_AND_INCR (mcnt, p); /* Get the amount to jump. */ DEBUG_PRINT2 ("EXECUTING jump %d ", mcnt); p += mcnt; /* Do the jump. */ - DEBUG_PRINT2 ("(to 0x%p).\n", p); + DEBUG_PRINT2 ("(to 0x%lx).\n", (long) p); break; @@ -5371,11 +5371,12 @@ mcnt--; p += 2; STORE_NUMBER_AND_INCR (p, mcnt); - DEBUG_PRINT3 (" Setting 0x%p to %d.\n", p, mcnt); + DEBUG_PRINT3 (" Setting 0x%lx to %d.\n", (long) p, mcnt); } else if (mcnt == 0) { - DEBUG_PRINT2 (" Setting two bytes from 0x%p to no_op.\n", p+2); + DEBUG_PRINT2 (" Setting two bytes from 0x%lx to no_op.\n", + (long) (p+2)); p[2] = (unsigned char) no_op; p[3] = (unsigned char) no_op; goto on_failure; @@ -5405,7 +5406,7 @@ EXTRACT_NUMBER_AND_INCR (mcnt, p); p1 = p + mcnt; EXTRACT_NUMBER_AND_INCR (mcnt, p); - DEBUG_PRINT3 (" Setting 0x%p to %d.\n", p1, mcnt); + DEBUG_PRINT3 (" Setting 0x%lx to %d.\n", (long) p1, mcnt); STORE_NUMBER (p1, mcnt); break; } diff -r 76b7d63099ad -r 8626e4521993 src/s/freebsd.h --- a/src/s/freebsd.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/s/freebsd.h Mon Aug 13 11:07:10 2007 +0200 @@ -55,7 +55,7 @@ #endif #define LD_SWITCH_SYSTEM #define START_FILES pre-crt0.o /usr/lib/crt1.o /usr/lib/crti.o /usr/lib/crtbegin.o -#define UNEXEC unexelf.o +#define UNEXEC "unexelf.o" #define LIB_STANDARD -lgcc -lc -lgcc /usr/lib/crtend.o /usr/lib/crtn.o #define LINKER "$(CC) -nostdlib" #undef LIB_GCC diff -r 76b7d63099ad -r 8626e4521993 src/s/linux.h --- a/src/s/linux.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/s/linux.h Mon Aug 13 11:07:10 2007 +0200 @@ -131,6 +131,13 @@ /* mrb - Ordinary link is simple and effective */ /* slb - Not any more ... :-( */ #define ORDINARY_LINK +#endif /* 0 */ + +/* I still think ORDINARY_LINK should be the default, but since slb + insists, ORDINARY_LINK will stay on until we expunge the dump code. + However, the user (i.e. me!) should be able to specify ORDINARY_LINK via + configure --cppflags=-DORDINARY_LINK ... */ +#ifdef ORDINARY_LINK #undef LIB_STANDARD #undef START_FILES #undef LIB_GCC diff -r 76b7d63099ad -r 8626e4521993 src/s/msdos.h --- a/src/s/msdos.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/s/msdos.h Mon Aug 13 11:07:10 2007 +0200 @@ -169,7 +169,7 @@ #define FLOAT_CHECK_DOMAIN /* When $TERM is "internal" then this is substituted: */ -#define INTERNAL_TERMINAL "pc|bios|IBM PC with colour display:\ +#define INTERNAL_TERMINAL "pc|bios|IBM PC with color display:\ :co#80:li#25:km:ms:cm=:cl=:ce=:" /* Define this to a function (Fdowncase, Fupcase) if your file system diff -r 76b7d63099ad -r 8626e4521993 src/scrollbar-msw.c --- a/src/scrollbar-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/scrollbar-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -1,6 +1,6 @@ /* scrollbar implementation -- mswindows interface. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. - Copyright (C) 1994 Amdhal Corporation. + Copyright (C) 1994 Amdahl Corporation. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred . diff -r 76b7d63099ad -r 8626e4521993 src/scrollbar-x.c --- a/src/scrollbar-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/scrollbar-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -1,6 +1,6 @@ /* scrollbar implementation -- X interface. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. - Copyright (C) 1994 Amdhal Corporation. + Copyright (C) 1994 Amdahl Corporation. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred . @@ -28,8 +28,6 @@ #include "console-x.h" #include "glyphs-x.h" -#include "EmacsFrame.h" -#include "EmacsManager.h" #include "gui-x.h" #include "scrollbar-x.h" diff -r 76b7d63099ad -r 8626e4521993 src/scrollbar.c --- a/src/scrollbar.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/scrollbar.c Mon Aug 13 11:07:10 2007 +0200 @@ -95,10 +95,10 @@ static void free_window_mirror_scrollbars (struct window_mirror *mir) { - struct frame *f = mir->frame; - free_scrollbar_instance (mir->scrollbar_vertical_instance, f); + free_scrollbar_instance (mir->scrollbar_vertical_instance, mir->frame); mir->scrollbar_vertical_instance = 0; - free_scrollbar_instance (mir->scrollbar_horizontal_instance, f); + + free_scrollbar_instance (mir->scrollbar_horizontal_instance, mir->frame); mir->scrollbar_horizontal_instance = 0; } @@ -109,12 +109,7 @@ while (mir) { - struct scrollbar_instance *vinst = mir->scrollbar_vertical_instance; - struct scrollbar_instance *hinst = mir->scrollbar_horizontal_instance; - struct frame *f; - assert (!NILP (window)); - f = XFRAME (XWINDOW (window)->frame); if (mir->vchild) { @@ -130,7 +125,8 @@ if (retval != NULL) return retval; - if (hinst || vinst) + if (mir->scrollbar_vertical_instance || + mir->scrollbar_horizontal_instance) free_window_mirror_scrollbars (mir); mir = mir->next; @@ -141,19 +137,7 @@ } /* Destroy all scrollbars associated with FRAME. Only called from - delete_frame_internal. - */ -#define FREE_FRAME_SCROLLBARS_INTERNAL(cache) \ - do { \ - while (FRAME_SB_##cache (f)) \ - { \ - struct scrollbar_instance *tofree = FRAME_SB_##cache (f); \ - FRAME_SB_##cache (f) = FRAME_SB_##cache (f)->next; \ - tofree->next = NULL; \ - free_scrollbar_instance (tofree, f); \ - } \ - } while (0) - + delete_frame_internal. */ void free_frame_scrollbars (struct frame *f) { @@ -165,10 +149,22 @@ free_scrollbars_loop (f->root_window, f->root_mirror); - FREE_FRAME_SCROLLBARS_INTERNAL (VCACHE); - FREE_FRAME_SCROLLBARS_INTERNAL (HCACHE); + while (FRAME_SB_VCACHE (f)) + { + struct scrollbar_instance *tofree = FRAME_SB_VCACHE (f); + FRAME_SB_VCACHE (f) = FRAME_SB_VCACHE (f)->next; + tofree->next = NULL; + free_scrollbar_instance (tofree, f); + } + + while (FRAME_SB_HCACHE (f)) + { + struct scrollbar_instance *tofree = FRAME_SB_HCACHE (f); + FRAME_SB_HCACHE (f) = FRAME_SB_HCACHE (f)->next; + tofree->next = NULL; + free_scrollbar_instance (tofree, f); + } } -#undef FREE_FRAME_SCROLLBARS_INTERNAL static struct scrollbar_instance * @@ -354,13 +350,6 @@ mir->scrollbar_horizontal_instance = 0; } -/* This check needs to be done in the device-specific side. */ -#define UPDATE_DATA_FIELD(field, value) \ - if (instance->field != value) {\ - instance->field = value;\ - instance->scrollbar_instance_changed = 1;\ - }\ - /* * If w->sb_point is on the top line then return w->sb_point else * return w->start. If flag, then return beginning point of line @@ -598,7 +587,7 @@ changing scrollbar affects only how the text and scrollbar are laid out in the window. If we do not want the dividers to show up always, then we mark more drastic change, because changing - divider appearane changes lotta things. Although we actually need + divider appearance changes lotta things. Although we actually need to do this only if the scrollbar has appeared or disappeared completely at either window edge, we do this always, as users usually do not reposition scrollbars 200 times a second or so. Do @@ -872,7 +861,7 @@ /* Can't allow this out of set-window-hscroll's acceptable range. */ /* #### What hell on the earth this code limits scroll size to the - machine-dependant SHORT size? -- kkm */ + machine-dependent SHORT size? -- kkm */ if (hscroll < 0) hscroll = 0; else if (hscroll >= (1 << (SHORTBITS - 1)) - 1) @@ -1002,13 +991,13 @@ frame_size_slipped); DEFVAR_SPECIFIER ("scrollbar-on-left-p", &Vscrollbar_on_left_p /* -*Whether the verical scrollbar is on the left side of window or frame. +*Whether the vertical scrollbar is on the left side of window or frame. This is a specifier; use `set-specifier' to change it. */ ); Vscrollbar_on_left_p = Fmake_specifier (Qboolean); { - /* Klugde. Under X, we want athena scrollbars on the left, + /* Kludge. Under X, we want athena scrollbars on the left, while all other scrollbars go on the right by default. */ Lisp_Object fallback = list1 (Fcons (Qnil, Qnil)); #if defined (HAVE_X_WINDOWS) \ @@ -1030,7 +1019,7 @@ frame_size_slipped); DEFVAR_SPECIFIER ("scrollbar-on-top-p", &Vscrollbar_on_top_p /* -*Whether the verical scrollbar is on the top side of window or frame. +*Whether the horizontal scrollbar is on the top side of window or frame. This is a specifier; use `set-specifier' to change it. */ ); Vscrollbar_on_top_p = Fmake_specifier (Qboolean); diff -r 76b7d63099ad -r 8626e4521993 src/search.c --- a/src/search.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/search.c Mon Aug 13 11:07:10 2007 +0200 @@ -29,7 +29,6 @@ #include "lisp.h" #include "buffer.h" -#include "commands.h" #include "insdel.h" #include "opaque.h" #ifdef REGION_CACHE_NEEDS_WORK @@ -684,31 +683,31 @@ } Bytind -bi_find_next_newline_no_quit (struct buffer *buf, Bytind from, int cnt) +bi_find_next_newline_no_quit (struct buffer *buf, Bytind from, int count) { - return bi_scan_buffer (buf, '\n', from, 0, cnt, 0, 0); + return bi_scan_buffer (buf, '\n', from, 0, count, 0, 0); } Bufpos -find_next_newline_no_quit (struct buffer *buf, Bufpos from, int cnt) +find_next_newline_no_quit (struct buffer *buf, Bufpos from, int count) { - return scan_buffer (buf, '\n', from, 0, cnt, 0, 0); + return scan_buffer (buf, '\n', from, 0, count, 0, 0); } Bufpos -find_next_newline (struct buffer *buf, Bufpos from, int cnt) +find_next_newline (struct buffer *buf, Bufpos from, int count) { - return scan_buffer (buf, '\n', from, 0, cnt, 0, 1); + return scan_buffer (buf, '\n', from, 0, count, 0, 1); } /* Like find_next_newline, but returns position before the newline, not after, and only search up to TO. This isn't just find_next_newline (...)-1, because you might hit TO. */ Bufpos -find_before_next_newline (struct buffer *buf, Bufpos from, Bufpos to, int cnt) +find_before_next_newline (struct buffer *buf, Bufpos from, Bufpos to, int count) { EMACS_INT shortage; - Bufpos pos = scan_buffer (buf, '\n', from, to, cnt, &shortage, 1); + Bufpos pos = scan_buffer (buf, '\n', from, to, count, &shortage, 1); if (shortage == 0) pos--; @@ -730,20 +729,21 @@ REGISTER int i; struct Lisp_Char_Table *syntax_table = XCHAR_TABLE (buf->mirror_syntax_table); - - CHECK_STRING (string); + Bufpos limit; if (NILP (lim)) - XSETINT (lim, forwardp ? BUF_ZV (buf) : BUF_BEGV (buf)); + limit = forwardp ? BUF_ZV (buf) : BUF_BEGV (buf); else - CHECK_INT_COERCE_MARKER (lim); + { + CHECK_INT_COERCE_MARKER (lim); + limit = XINT (lim); - /* In any case, don't allow scan outside bounds of buffer. */ - if (XINT (lim) > BUF_ZV (buf)) - lim = make_int (BUF_ZV (buf)); - if (XINT (lim) < BUF_BEGV (buf)) - lim = make_int (BUF_BEGV (buf)); + /* In any case, don't allow scan outside bounds of buffer. */ + if (limit > BUF_ZV (buf)) limit = BUF_ZV (buf); + if (limit < BUF_BEGV (buf)) limit = BUF_BEGV (buf); + } + CHECK_STRING (string); p = XSTRING_DATA (string); pend = p + XSTRING_LENGTH (string); memset (fastmap, 0, sizeof (fastmap)); @@ -828,7 +828,7 @@ to worry about */ if (forwardp) { - while (BUF_PT (buf) < XINT (lim) + while (BUF_PT (buf) < limit && fastmap[(unsigned char) syntax_code_spec [(int) SYNTAX (syntax_table, @@ -838,7 +838,7 @@ } else { - while (BUF_PT (buf) > XINT (lim) + while (BUF_PT (buf) > limit && fastmap[(unsigned char) syntax_code_spec [(int) SYNTAX (syntax_table, @@ -851,7 +851,7 @@ { if (forwardp) { - while (BUF_PT (buf) < XINT (lim)) + while (BUF_PT (buf) < limit) { Emchar ch = BUF_FETCH_CHAR (buf, BUF_PT (buf)); if ((ch < 0400) ? fastmap[ch] : @@ -866,7 +866,7 @@ } else { - while (BUF_PT (buf) > XINT (lim)) + while (BUF_PT (buf) > limit) { Emchar ch = BUF_FETCH_CHAR (buf, BUF_PT (buf) - 1); if ((ch < 0400) ? fastmap[ch] : @@ -1383,7 +1383,7 @@ (EMACS_UINT) p_limit) cursor += BM_tab[*cursor]; } -/* If you are here, cursor is beyond the end of the searched region. */ + /* If you are here, cursor is beyond the end of the searched region. */ /* This can happen if you match on the far character of the pattern, */ /* because the "stride" of that character is infinity, a number able */ /* to throw you well beyond the end of the search. It can also */ @@ -1837,7 +1837,7 @@ case_action = nochange; /* We tried an initialization */ /* but some C compilers blew it */ - if (search_regs.num_regs <= 0) + if (search_regs.num_regs == 0) error ("replace-match called before any match found"); if (NILP (string)) @@ -2219,7 +2219,7 @@ n = XINT (num); if (n < 0 || n >= search_regs.num_regs) args_out_of_range (num, make_int (search_regs.num_regs)); - if (search_regs.num_regs <= 0 || + if (search_regs.num_regs == 0 || search_regs.start[n] < 0) return Qnil; return make_int (beginningp ? search_regs.start[n] : search_regs.end[n]); @@ -2310,7 +2310,7 @@ /* If REUSE is a list, store as many value elements as will fit into the elements of REUSE. */ - for (i = 0, tail = reuse; CONSP (tail); i++, tail = XCDR (tail)) + for (prev = Qnil, i = 0, tail = reuse; CONSP (tail); i++, tail = XCDR (tail)) { if (i < 2 * len + 2) XCAR (tail) = data[i]; diff -r 76b7d63099ad -r 8626e4521993 src/signal.c --- a/src/signal.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/signal.c Mon Aug 13 11:07:10 2007 +0200 @@ -355,7 +355,7 @@ This is intended for use by asynchronous timeout callbacks and by asynchronous process output filters and sentinels (not yet implemented in XEmacs). It will always be nil if XEmacs is not inside of -an asynchronout timeout or process callback. +an asynchronous timeout or process callback. */ ()) { diff -r 76b7d63099ad -r 8626e4521993 src/sound.c --- a/src/sound.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sound.c Mon Aug 13 11:07:10 2007 +0200 @@ -32,7 +32,6 @@ #include "console-x.h" #endif -#include "commands.h" #include "device.h" #include "redisplay.h" #include "sysdep.h" @@ -456,7 +455,7 @@ else { /* We have to call gethostbyname() on the result of gethostname() - because the two aren't guarenteed to be the same name for the + because the two aren't guaranteed to be the same name for the same host: on some losing systems, one is a FQDN and the other is not. Here in the wide wonderful world of Unix it's rocket science to obtain the local hostname in a portable fashion. diff -r 76b7d63099ad -r 8626e4521993 src/specifier.c --- a/src/specifier.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/specifier.c Mon Aug 13 11:07:10 2007 +0200 @@ -183,13 +183,13 @@ { struct Lisp_Specifier *specifier = XSPECIFIER (obj); - ((markobj) (specifier->global_specs)); - ((markobj) (specifier->device_specs)); - ((markobj) (specifier->frame_specs)); - ((markobj) (specifier->window_specs)); - ((markobj) (specifier->buffer_specs)); - ((markobj) (specifier->magic_parent)); - ((markobj) (specifier->fallback)); + markobj (specifier->global_specs); + markobj (specifier->device_specs); + markobj (specifier->frame_specs); + markobj (specifier->window_specs); + markobj (specifier->buffer_specs); + markobj (specifier->magic_parent); + markobj (specifier->fallback); if (!GHOST_SPECIFIER_P (XSPECIFIER (obj))) MAYBE_SPECMETH (specifier, mark, (obj, markobj)); return Qnil; @@ -223,14 +223,14 @@ !GC_NILP (rest); rest = XSPECIFIER (rest)->next_specifier) { - if (! ((*obj_marked_p) (rest))) + if (! obj_marked_p (rest)) { struct Lisp_Specifier* sp = XSPECIFIER (rest); /* A bit of assertion that we're removing both parts of the magic one altogether */ assert (!GC_MAGIC_SPECIFIER_P(sp) - || (GC_BODILY_SPECIFIER_P(sp) && (*obj_marked_p)(sp->fallback)) - || (GC_GHOST_SPECIFIER_P(sp) && (*obj_marked_p)(sp->magic_parent))); + || (GC_BODILY_SPECIFIER_P(sp) && obj_marked_p (sp->fallback)) + || (GC_GHOST_SPECIFIER_P(sp) && obj_marked_p (sp->magic_parent))); /* This specifier is garbage. Remove it from the list. */ if (GC_NILP (prev)) Vall_specifiers = sp->next_specifier; @@ -287,10 +287,10 @@ } static int -specifier_equal (Lisp_Object o1, Lisp_Object o2, int depth) +specifier_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Specifier *s1 = XSPECIFIER (o1); - struct Lisp_Specifier *s2 = XSPECIFIER (o2); + struct Lisp_Specifier *s1 = XSPECIFIER (obj1); + struct Lisp_Specifier *s2 = XSPECIFIER (obj2); int retval; Lisp_Object old_inhibit_quit = Vinhibit_quit; @@ -309,7 +309,7 @@ internal_equal (s1->fallback, s2->fallback, depth)); if (retval && HAS_SPECMETH_P (s1, equal)) - retval = SPECMETH (s1, equal, (o1, o2, depth - 1)); + retval = SPECMETH (s1, equal, (obj1, obj2, depth - 1)); Vinhibit_quit = old_inhibit_quit; return retval; @@ -637,16 +637,21 @@ /* This cannot GC. */ /* The return value of this function must be GCPRO'd. */ if (NILP (locale)) - locale = list1 (Qall); + { + return list1 (Qall); + } + else if (CONSP (locale)) + { + Lisp_Object elt; + EXTERNAL_LIST_LOOP_2 (elt, locale) + check_valid_locale_or_locale_type (elt); + return locale; + } else { - Lisp_Object rest; - if (!CONSP (locale)) - locale = list1 (locale); - EXTERNAL_LIST_LOOP (rest, locale) - check_valid_locale_or_locale_type (XCAR (rest)); + check_valid_locale_or_locale_type (locale); + return list1 (locale); } - return locale; } static enum spec_locale_type @@ -1846,7 +1851,7 @@ CHECK_SPECIFIER (specifier); check_modifiable_specifier (specifier); - + locale = decode_locale (locale); check_valid_instantiator (instantiator, decode_specifier_type @@ -2405,18 +2410,17 @@ specific (buffer) to most general (global). If we find an instance, return it. Otherwise return Qunbound. */ -#define CHECK_INSTANCE_ENTRY(key, matchspec, type) \ -do { \ - Lisp_Object *__inst_list = \ +#define CHECK_INSTANCE_ENTRY(key, matchspec, type) do { \ + Lisp_Object *CIE_inst_list = \ specifier_get_inst_list (specifier, key, type); \ - if (__inst_list) \ + if (CIE_inst_list) \ { \ - Lisp_Object __val__ = \ + Lisp_Object CIE_val = \ specifier_instance_from_inst_list (specifier, matchspec, \ - domain, *__inst_list, \ + domain, *CIE_inst_list, \ errb, no_quit, depth); \ - if (!UNBOUNDP (__val__)) \ - return __val__; \ + if (!UNBOUNDP (CIE_val)) \ + return CIE_val; \ } \ } while (0) @@ -2480,7 +2484,7 @@ goto do_fallback; } -try_again: +retry: /* First see if we can generate one from the window specifiers. */ if (!NILP (window)) CHECK_INSTANCE_ENTRY (window, matchspec, LOCALE_WINDOW); @@ -2514,7 +2518,7 @@ then you're fucked, so you better not do this. */ specifier = sp->fallback; sp = XSPECIFIER (specifier); - goto try_again; + goto retry; } assert (CONSP (sp->fallback)); @@ -3126,7 +3130,7 @@ staticpro (&Vcached_specifiers); /* Do NOT mark through this, or specifiers will never be GC'd. - This is the same deal as for weak hashtables. */ + This is the same deal as for weak hash tables. */ Vall_specifiers = Qnil; Vuser_defined_tags = Qnil; diff -r 76b7d63099ad -r 8626e4521993 src/specifier.h --- a/src/specifier.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/specifier.h Mon Aug 13 11:07:10 2007 +0200 @@ -34,7 +34,7 @@ etc. A magic specifier consists of two specifier objects. The first one - behaves like a normal specifier in all sences. The second one, a + behaves like a normal specifier in all senses. The second one, a ghost specifier, is a fallback value for the first one, and contains values provided by window system, resources etc. which reflect default settings for values being specified. @@ -61,11 +61,11 @@ frame defaults, such as init-{global,frame,device}-{faces,toolbars,etc}. - Thus, values supplied by resources or other means of a window system + Thus, values supplied by resources or other means of a window system stored in externally unmodifiable ghost objects. Regular lisp code may thus freely modify the normal part of a magic specifier, and removing a specification for a particular domain causes the - specification to consider ghost-provided fallback values, or its own + specification to consider ghost-provided fallback values, or its own fallback value. Rules of conduct for magic specifiers @@ -76,10 +76,10 @@ 2. All specifier methods, except for instantiate method, are passed the bodily object of the magic specifier. Instantiate method is passed the specifier being instantiated. - 3. Only bodily objects are passed to set_specifier_caching function, + 3. Only bodily objects are passed to set_specifier_caching function, and only these may be cached. - 4. All specifiers are added to Vall_specifiers list, both bodily and - ghost. The pair of objects is always removed from the list at the + 4. All specifiers are added to Vall_specifiers list, both bodily and + ghost. The pair of objects is always removed from the list at the same time. */ @@ -98,7 +98,7 @@ void (*mark_method) (Lisp_Object specifier, void (*markobj) (Lisp_Object)); /* Equal method: Compare two specifiers. This is called after - ensuring that the two specifiers are of the same type, and habe + ensuring that the two specifiers are of the same type, and have the same specs. Quit is inhibited during the call so it is safe to call internal_equal(). @@ -220,7 +220,7 @@ the ghost part of the magic specifier, a pointer to its parent object */ Lisp_Object magic_parent; - + /* Fallback value. For magic specifiers, it is a pointer to the ghost. */ Lisp_Object fallback; @@ -244,9 +244,9 @@ /* Call a void-returning specifier method, if it exists. */ #define MAYBE_SPECMETH(sp, m, args) do { \ - struct Lisp_Specifier *_maybe_specmeth_sp = (sp); \ - if (HAS_SPECMETH_P (_maybe_specmeth_sp, m)) \ - SPECMETH (_maybe_specmeth_sp, m, args); \ + struct Lisp_Specifier *maybe_specmeth_sp = (sp); \ + if (HAS_SPECMETH_P (maybe_specmeth_sp, m)) \ + SPECMETH (maybe_specmeth_sp, m, args); \ } while (0) /***** Defining new specifier types *****/ diff -r 76b7d63099ad -r 8626e4521993 src/sunplay.c --- a/src/sunplay.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sunplay.c Mon Aug 13 11:07:10 2007 +0200 @@ -61,7 +61,7 @@ static int audio_fd; -#define audio_open() open ("/dev/audio", (O_WRONLY | O_NDELAY), 0) +#define audio_open() open ("/dev/audio", (O_WRONLY | O_NONBLOCK), 0) static int reset_volume_p, reset_device_p; static double old_volume; diff -r 76b7d63099ad -r 8626e4521993 src/symbols.c --- a/src/symbols.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/symbols.c Mon Aug 13 11:07:10 2007 +0200 @@ -56,8 +56,7 @@ #include "buffer.h" /* for Vbuffer_defaults */ #include "console.h" - -#include "elhash.h" /* for HASHTABLE_NONWEAK and HASHTABLE_EQ */ +#include "elhash.h" Lisp_Object Qad_advice_info, Qad_activate; @@ -66,7 +65,8 @@ Lisp_Object Qboundp, Qfboundp, Qglobally_boundp, Qmakunbound; Lisp_Object Qsymbol_value, Qset, Qdefault_boundp, Qdefault_value; -Lisp_Object Qset_default, Qmake_variable_buffer_local, Qmake_local_variable; +Lisp_Object Qset_default, Qsetq_default; +Lisp_Object Qmake_variable_buffer_local, Qmake_local_variable; Lisp_Object Qkill_local_variable, Qkill_console_local_variable; Lisp_Object Qsymbol_value_in_buffer, Qsymbol_value_in_console; Lisp_Object Qlocal_variable_p; @@ -80,12 +80,10 @@ Lisp_Object funsym, int nargs, ...); static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym, - Lisp_Object - follow_past_lisp_magic); + Lisp_Object follow_past_lisp_magic); static Lisp_Object *value_slot_past_magic (Lisp_Object sym); -static Lisp_Object follow_varalias_pointers (Lisp_Object object, - Lisp_Object - follow_past_lisp_magic); +static Lisp_Object follow_varalias_pointers (Lisp_Object symbol, + Lisp_Object follow_past_lisp_magic); #ifdef LRECORD_SYMBOL @@ -96,17 +94,17 @@ struct Lisp_Symbol *sym = XSYMBOL (obj); Lisp_Object pname; - ((markobj) (sym->value)); - ((markobj) (sym->function)); + markobj (sym->value); + markobj (sym->function); /* No need to mark through ->obarray, because it only holds nil or t. */ - /*((markobj) (sym->obarray));*/ + /* markobj (sym->obarray);*/ XSETSTRING (pname, sym->name); - ((markobj) (pname)); + markobj (pname); if (!symbol_next (sym)) return sym->plist; else { - ((markobj) (sym->plist)); + markobj (sym->plist); /* Mark the rest of the symbols in the obarray hash-chain */ sym = symbol_next (sym); XSETSYMBOL (obj, sym); @@ -150,18 +148,22 @@ Lisp_Object intern (CONST char *str) { - Lisp_Object tem; Bytecount len = strlen (str); + CONST Bufbyte *buf = (CONST Bufbyte *) str; Lisp_Object obarray = Vobarray; + if (!VECTORP (obarray) || XVECTOR_LENGTH (obarray) == 0) obarray = check_obarray (obarray); - tem = oblookup (obarray, (CONST Bufbyte *) str, len); - - if (SYMBOLP (tem)) - return tem; - return Fintern (((purify_flag) - ? make_pure_pname ((CONST Bufbyte *) str, len, 0) - : make_string ((CONST Bufbyte *) str, len)), + + { + Lisp_Object tem = oblookup (obarray, buf, len); + if (SYMBOLP (tem)) + return tem; + } + + return Fintern ((purify_flag + ? make_pure_pname (buf, len, 0) + : make_string (buf, len)), obarray); } @@ -171,7 +173,7 @@ A second optional argument specifies the obarray to use; it defaults to the value of `obarray'. */ - (str, obarray)) + (string, obarray)) { Lisp_Object sym, *ptr; Bytecount len; @@ -179,19 +181,19 @@ if (NILP (obarray)) obarray = Vobarray; obarray = check_obarray (obarray); - CHECK_STRING (str); - - len = XSTRING_LENGTH (str); - sym = oblookup (obarray, XSTRING_DATA (str), len); + CHECK_STRING (string); + + len = XSTRING_LENGTH (string); + sym = oblookup (obarray, XSTRING_DATA (string), len); if (!INTP (sym)) /* Found it */ return sym; ptr = &XVECTOR_DATA (obarray)[XINT (sym)]; - if (purify_flag && ! purified (str)) - str = make_pure_pname (XSTRING_DATA (str), len, 0); - sym = Fmake_symbol (str); + if (purify_flag && ! purified (string)) + string = make_pure_pname (XSTRING_DATA (string), len, 0); + sym = Fmake_symbol (string); /* FSFmacs places OBARRAY here, but it is pointless because we do not mark through this slot, so it is not usable later (because the obarray might have been collected). Marking through the @@ -217,19 +219,17 @@ 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); - - tem = oblookup (obarray, XSTRING_DATA (str), XSTRING_LENGTH (str)); - if (!INTP (tem)) - return tem; - return Qnil; + CHECK_STRING (string); + + tem = oblookup (obarray, XSTRING_DATA (string), XSTRING_LENGTH (string)); + return !INTP (tem) ? tem : Qnil; } DEFUN ("unintern", Funintern, 1, 2, 0, /* @@ -293,7 +293,7 @@ /* Return the symbol in OBARRAY whose names matches the string of SIZE characters at PTR. If there is no such symbol in OBARRAY, - return nil. + return the index into OBARRAY that the string hashes to. Also store the bucket number in oblookup_last_bucket_number. */ @@ -315,11 +315,9 @@ /* 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; + hash = hash_string (ptr, size) % obsize; + oblookup_last_bucket_number = hash; bucket = XVECTOR_DATA (obarray)[hash]; - oblookup_last_bucket_number = hash; if (ZEROP (bucket)) ; else if (!SYMBOLP (bucket)) @@ -484,29 +482,29 @@ DEFUN ("boundp", Fboundp, 1, 1, 0, /* Return t if SYMBOL's value is not void. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return UNBOUNDP (find_symbol_value (sym)) ? Qnil : Qt; + CHECK_SYMBOL (symbol); + return UNBOUNDP (find_symbol_value (symbol)) ? Qnil : Qt; } DEFUN ("globally-boundp", Fglobally_boundp, 1, 1, 0, /* Return t if SYMBOL has a global (non-bound) value. This is for the byte-compiler; you really shouldn't be using this. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return UNBOUNDP (top_level_value (sym)) ? Qnil : Qt; + CHECK_SYMBOL (symbol); + return UNBOUNDP (top_level_value (symbol)) ? Qnil : Qt; } DEFUN ("fboundp", Ffboundp, 1, 1, 0, /* Return t if SYMBOL's function definition is not void. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return UNBOUNDP (XSYMBOL (sym)->function) ? Qnil : Qt; + CHECK_SYMBOL (symbol); + return UNBOUNDP (XSYMBOL (symbol)->function) ? Qnil : Qt; } /* Return non-zero if SYM's value or function (the current contents of @@ -537,7 +535,7 @@ } /* We don't return true for keywords here because they are handled - specially by reject_constant_symbols(). */ + specially by reject_constant_symbols(). */ return 0; } @@ -546,7 +544,7 @@ FOLLOW_PAST_LISP_MAGIC specifies whether we delve past symbol-value-lisp-magic objects. */ -static void +void reject_constant_symbols (Lisp_Object sym, Lisp_Object newval, int function_p, Lisp_Object follow_past_lisp_magic) { @@ -603,21 +601,21 @@ DEFUN ("makunbound", Fmakunbound, 1, 1, 0, /* Make SYMBOL's value be void. */ - (sym)) + (symbol)) { - Fset (sym, Qunbound); - return sym; + Fset (symbol, Qunbound); + return symbol; } DEFUN ("fmakunbound", Ffmakunbound, 1, 1, 0, /* Make SYMBOL's function definition be void. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - reject_constant_symbols (sym, Qunbound, 1, Qt); - XSYMBOL (sym)->function = Qunbound; - return sym; + CHECK_SYMBOL (symbol); + reject_constant_symbols (symbol, Qunbound, 1, Qt); + XSYMBOL (symbol)->function = Qunbound; + return symbol; } DEFUN ("symbol-function", Fsymbol_function, 1, 1, 0, /* @@ -627,49 +625,49 @@ { CHECK_SYMBOL (symbol); if (UNBOUNDP (XSYMBOL (symbol)->function)) - return Fsignal (Qvoid_function, list1 (symbol)); + signal_void_function_error (symbol); return XSYMBOL (symbol)->function; } DEFUN ("symbol-plist", Fsymbol_plist, 1, 1, 0, /* Return SYMBOL's property list. */ - (sym)) + (symbol)) { - CHECK_SYMBOL (sym); - return XSYMBOL (sym)->plist; + CHECK_SYMBOL (symbol); + return XSYMBOL (symbol)->plist; } DEFUN ("symbol-name", Fsymbol_name, 1, 1, 0, /* Return SYMBOL's name, a string. */ - (sym)) + (symbol)) { Lisp_Object name; - CHECK_SYMBOL (sym); - XSETSTRING (name, XSYMBOL (sym)->name); + CHECK_SYMBOL (symbol); + XSETSTRING (name, XSYMBOL (symbol)->name); return name; } DEFUN ("fset", Ffset, 2, 2, 0, /* Set SYMBOL's function definition to NEWDEF, and return NEWDEF. */ - (sym, newdef)) + (symbol, newdef)) { /* This function can GC */ - CHECK_SYMBOL (sym); - reject_constant_symbols (sym, newdef, 1, Qt); - if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (sym)->function)) - Vautoload_queue = Fcons (Fcons (sym, XSYMBOL (sym)->function), + CHECK_SYMBOL (symbol); + reject_constant_symbols (symbol, newdef, 1, Qt); + if (!NILP (Vautoload_queue) && !UNBOUNDP (XSYMBOL (symbol)->function)) + Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function), Vautoload_queue); - XSYMBOL (sym)->function = newdef; + XSYMBOL (symbol)->function = newdef; /* Handle automatic advice activation */ - if (CONSP (XSYMBOL (sym)->plist) && !NILP (Fget (sym, Qad_advice_info, - Qnil))) + if (CONSP (XSYMBOL (symbol)->plist) && + !NILP (Fget (symbol, Qad_advice_info, Qnil))) { - call2 (Qad_activate, sym, Qnil); - newdef = XSYMBOL (sym)->function; + call2 (Qad_activate, symbol, Qnil); + newdef = XSYMBOL (symbol)->function; } return newdef; } @@ -679,12 +677,11 @@ Set SYMBOL's function definition to NEWDEF, and return NEWDEF. Associates the function with the current load file, if any. */ - (sym, newdef)) + (symbol, newdef)) { /* This function can GC */ - CHECK_SYMBOL (sym); - Ffset (sym, newdef); - LOADHIST_ATTACH (sym); + Ffset (symbol, newdef); + LOADHIST_ATTACH (symbol); return newdef; } @@ -692,16 +689,16 @@ DEFUN ("setplist", Fsetplist, 2, 2, 0, /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */ - (sym, newplist)) + (symbol, newplist)) { - CHECK_SYMBOL (sym); + CHECK_SYMBOL (symbol); #if 0 /* Inserted for debugging 6/28/1997 -slb */ /* Somebody is setting a property list of integer 0, who? */ /* Not this way apparently. */ if (EQ(newplist, Qzero)) abort(); #endif - XSYMBOL (sym)->plist = newplist; + XSYMBOL (symbol)->plist = newplist; return newplist; } @@ -719,7 +716,7 @@ If a symbol is "unbound", then the contents of its value cell is Qunbound. Despite appearances, this is *not* a symbol, but is a symbol-value-forward object. This is so that printing it results - in "INTERNAL EMACS BUG", in case it leaks to Lisp, somehow. + in "INTERNAL OBJECT (XEmacs bug?)", in case it leaks to Lisp, somehow. Logically all of the following objects are "symbol-value-magic" objects, and there are some games played w.r.t. this (#### this @@ -900,13 +897,15 @@ { struct symbol_value_buffer_local *bfwd; +#ifdef ERROR_CHECK_TYPECHECK assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_BUFFER_LOCAL || XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_SOME_BUFFER_LOCAL); +#endif bfwd = XSYMBOL_VALUE_BUFFER_LOCAL (obj); - ((markobj) (bfwd->default_value)); - ((markobj) (bfwd->current_value)); - ((markobj) (bfwd->current_buffer)); + markobj (bfwd->default_value); + markobj (bfwd->current_value); + markobj (bfwd->current_buffer); return bfwd->current_alist_element; } @@ -922,8 +921,8 @@ bfwd = XSYMBOL_VALUE_LISP_MAGIC (obj); for (i = 0; i < MAGIC_HANDLER_MAX; i++) { - ((markobj) (bfwd->handler[i])); - ((markobj) (bfwd->harg[i])); + markobj (bfwd->handler[i]); + markobj (bfwd->harg[i]); } return bfwd->shadowed; } @@ -937,7 +936,7 @@ assert (XSYMBOL_VALUE_MAGIC_TYPE (obj) == SYMVAL_VARALIAS); bfwd = XSYMBOL_VALUE_VARALIAS (obj); - ((markobj) (bfwd->shadowed)); + markobj (bfwd->shadowed); return bfwd->aliasee; } @@ -947,10 +946,10 @@ Lisp_Object printcharfun, int escapeflag) { char buf[200]; - sprintf (buf, "#", + sprintf (buf, "#", XRECORD_LHEADER_IMPLEMENTATION (obj)->name, XSYMBOL_VALUE_MAGIC_TYPE (obj), - (void *) XPNTR (obj)); + (long) XPNTR (obj)); write_c_string (buf, printcharfun); } @@ -1081,16 +1080,16 @@ if (mask > 0) /* Not always per-buffer */ { - Lisp_Object tail; + Lisp_Object elt; /* Set value in each buffer which hasn't shadowed the default */ - LIST_LOOP (tail, Vbuffer_alist) + LIST_LOOP_2 (elt, Vbuffer_alist) { - struct buffer *b = XBUFFER (XCDR (XCAR (tail))); + struct buffer *b = XBUFFER (XCDR (elt)); if (!(b->local_var_flags & mask)) { if (magicfun) - (magicfun) (sym, &value, make_buffer (b), 0); + magicfun (sym, &value, make_buffer (b), 0); *((Lisp_Object *) (offset + (char *) b)) = value; } } @@ -1123,17 +1122,16 @@ if (mask > 0) /* Not always per-console */ { - Lisp_Object tail; + Lisp_Object console; /* Set value in each console which hasn't shadowed the default */ - LIST_LOOP (tail, Vconsole_list) + LIST_LOOP_2 (console, Vconsole_list) { - Lisp_Object dev = XCAR (tail); - struct console *d = XCONSOLE (dev); + struct console *d = XCONSOLE (console); if (!(d->local_var_flags & mask)) { if (magicfun) - (magicfun) (sym, &value, dev, 0); + magicfun (sym, &value, console, 0); *((Lisp_Object *) (offset + (char *) d)) = value; } } @@ -1175,77 +1173,60 @@ || !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); - - switch (type) + Lisp_Object in_object, int flags) + = symbol_value_forward_magicfun (fwd); + + switch (XSYMBOL_VALUE_MAGIC_TYPE (ovalue)) { case SYMVAL_FIXNUM_FORWARD: - { - CHECK_INT (newval); - if (magicfun) - (magicfun) (sym, &newval, Qnil, 0); - *((int *) symbol_value_forward_forward (fwd)) = XINT (newval); - return; - } + CHECK_INT (newval); + if (magicfun) + magicfun (sym, &newval, Qnil, 0); + *((int *) symbol_value_forward_forward (fwd)) = XINT (newval); + return; case SYMVAL_BOOLEAN_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, Qnil, 0); - *((int *) symbol_value_forward_forward (fwd)) - = ((NILP (newval)) ? 0 : 1); - return; - } + if (magicfun) + magicfun (sym, &newval, Qnil, 0); + *((int *) symbol_value_forward_forward (fwd)) + = ((NILP (newval)) ? 0 : 1); + return; case SYMVAL_OBJECT_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, Qnil, 0); - *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval; - return; - } + if (magicfun) + magicfun (sym, &newval, Qnil, 0); + *((Lisp_Object *) symbol_value_forward_forward (fwd)) = newval; + return; case SYMVAL_DEFAULT_BUFFER_FORWARD: - { - set_default_buffer_slot_variable (sym, newval); - return; - } + set_default_buffer_slot_variable (sym, newval); + return; case SYMVAL_CURRENT_BUFFER_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, make_buffer (current_buffer), 0); - *((Lisp_Object *) ((char *) current_buffer - + ((char *) symbol_value_forward_forward (fwd) - - (char *) &buffer_local_flags))) - = newval; - return; - } + if (magicfun) + magicfun (sym, &newval, make_buffer (current_buffer), 0); + *((Lisp_Object *) ((char *) current_buffer + + ((char *) symbol_value_forward_forward (fwd) + - (char *) &buffer_local_flags))) + = newval; + return; case SYMVAL_DEFAULT_CONSOLE_FORWARD: - { - set_default_console_slot_variable (sym, newval); - return; - } + set_default_console_slot_variable (sym, newval); + return; case SYMVAL_SELECTED_CONSOLE_FORWARD: - { - if (magicfun) - (magicfun) (sym, &newval, Vselected_console, 0); - *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console) - + ((char *) symbol_value_forward_forward (fwd) - - (char *) &console_local_flags))) - = newval; - return; - } + if (magicfun) + magicfun (sym, &newval, Vselected_console, 0); + *((Lisp_Object *) ((char *) XCONSOLE (Vselected_console) + + ((char *) symbol_value_forward_forward (fwd) + - (char *) &console_local_flags))) + = newval; + return; default: abort (); @@ -1335,7 +1316,7 @@ /* Retrieve the new alist element and new value. */ if (NILP (new_alist_el) && set_it_p) - new_alist_el = buffer_local_alist_element (buf, sym, bfwd); + new_alist_el = buffer_local_alist_element (buf, sym, bfwd); if (NILP (new_alist_el)) new_val = bfwd->default_value; @@ -1460,7 +1441,7 @@ else if (NILP (symcons)) { if (set_it_p) - valcontents = assq_no_quit (sym, buf->local_var_alist); + valcontents = assq_no_quit (sym, buf->local_var_alist); if (NILP (valcontents)) valcontents = bfwd->default_value; else @@ -1490,13 +1471,13 @@ CHECK_SYMBOL (sym); - if (!NILP (buffer)) + if (NILP (buffer)) + buf = current_buffer; + else { CHECK_BUFFER (buffer); buf = XBUFFER (buffer); } - else - buf = current_buffer; return find_symbol_value_1 (sym, buf, /* If it bombs out at startup due to a @@ -1510,10 +1491,10 @@ { CHECK_SYMBOL (sym); - if (!NILP (console)) + if (NILP (console)) + console = Vselected_console; + else CHECK_CONSOLE (console); - else - console = Vselected_console; return find_symbol_value_1 (sym, current_buffer, XCONSOLE (console), 0, Qnil, 1); @@ -1529,7 +1510,7 @@ { /* WARNING: This function can be called when current_buffer is 0 and Vselected_console is Qnil, early in initialization. */ - struct console *dev; + struct console *con; Lisp_Object valcontents; CHECK_SYMBOL (sym); @@ -1539,17 +1520,17 @@ return valcontents; if (CONSOLEP (Vselected_console)) - dev = XCONSOLE (Vselected_console); + con = XCONSOLE (Vselected_console); else { /* This can also get called while we're preparing to shutdown. #### What should really happen in that case? Should we actually fix things so we can't get here in that case? */ assert (!initialized || preparing_for_armageddon); - dev = 0; + con = 0; } - return find_symbol_value_1 (sym, current_buffer, dev, 1, Qnil, 1); + return find_symbol_value_1 (sym, current_buffer, con, 1, Qnil, 1); } /* This is an optimized function for quick lookup of buffer local symbols @@ -1570,22 +1551,22 @@ { /* WARNING: This function can be called when current_buffer is 0 and Vselected_console is Qnil, early in initialization. */ - struct console *dev; + struct console *con; Lisp_Object sym = find_it_p ? XCAR (symbol_cons) : symbol_cons; CHECK_SYMBOL (sym); if (CONSOLEP (Vselected_console)) - dev = XCONSOLE (Vselected_console); + con = XCONSOLE (Vselected_console); else { /* This can also get called while we're preparing to shutdown. #### What should really happen in that case? Should we actually fix things so we can't get here in that case? */ assert (!initialized || preparing_for_armageddon); - dev = 0; + con = 0; } - return find_symbol_value_1 (sym, current_buffer, dev, 1, + return find_symbol_value_1 (sym, current_buffer, con, 1, find_it_p ? symbol_cons : Qnil, find_it_p); } @@ -1593,12 +1574,12 @@ DEFUN ("symbol-value", Fsymbol_value, 1, 1, 0, /* Return SYMBOL's value. Error if that is void. */ - (sym)) + (symbol)) { - Lisp_Object val = find_symbol_value (sym); + Lisp_Object val = find_symbol_value (symbol); if (UNBOUNDP (val)) - return Fsignal (Qvoid_variable, list1 (sym)); + return Fsignal (Qvoid_variable, list1 (symbol)); else return val; } @@ -1606,177 +1587,181 @@ 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; - - 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; - } - - case SYMVAL_VARALIAS: - sym = follow_varalias_pointers (sym, - 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_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_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: + case SYMVAL_LISP_MAGIC: + { + Lisp_Object retval; + + 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: + 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"), symbol)); + 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_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 */ + )) { - /* 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 */ - )) - { - /* Cache is valid */ - valcontents = bfwd->current_value; - } - else + /* 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 (symbol, bfwd); + + /* Find the new value for CURRENT-ALIST-ELEMENT. */ + aelt = buffer_local_alist_element (current_buffer, symbol, bfwd); + if (NILP (aelt)) { - /* If the current buffer is not the buffer whose binding is - currently cached, or if it's a SYMVAL_BUFFER_LOCAL and - we're looking at the default value, the cache is invalid; we - need to write it out, and find the new CURRENT-ALIST-ELEMENT - */ - - /* Write out the cached value for the old buffer; copy it - back to its alist element. This works if the current - buffer only sees the default value, too. */ - write_out_buffer_local_cache (sym, bfwd); - - /* Find the new value for CURRENT-ALIST-ELEMENT. */ - aelt = buffer_local_alist_element (current_buffer, sym, bfwd); - if (NILP (aelt)) + /* This buffer is still seeing the default value. */ + if (!some_buffer_local_p) + { + /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a + new assoc for a local value and set + CURRENT-ALIST-ELEMENT to point to that. */ + aelt = + do_symval_forwarding (bfwd->current_value, + current_buffer, + XCONSOLE (Vselected_console)); + aelt = Fcons (symbol, aelt); + current_buffer->local_var_alist + = Fcons (aelt, current_buffer->local_var_alist); + } + else { - /* This buffer is still seeing the default value. */ - if (!some_buffer_local_p) - { - /* If it's a SYMVAL_BUFFER_LOCAL, give this buffer a - new assoc for a local value and set - CURRENT-ALIST-ELEMENT to point to that. */ - aelt = - do_symval_forwarding (bfwd->current_value, - current_buffer, - XCONSOLE (Vselected_console)); - aelt = Fcons (sym, aelt); - current_buffer->local_var_alist - = Fcons (aelt, current_buffer->local_var_alist); - } - else - { - /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL, - we're currently seeing the default value. */ - ; - } + /* If the variable is a SYMVAL_SOME_BUFFER_LOCAL, + we're currently seeing the default value. */ + ; } - /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ - bfwd->current_alist_element = aelt; - /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */ - XSETBUFFER (bfwd->current_buffer, current_buffer); - valcontents = bfwd->current_value; } - break; + /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */ + bfwd->current_alist_element = aelt; + /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */ + XSETBUFFER (bfwd->current_buffer, current_buffer); + valcontents = bfwd->current_value; } - default: - abort (); - } + break; + } + default: + abort (); } - store_symval_forwarding (sym, valcontents, newval); + store_symval_forwarding (symbol, valcontents, newval); return newval; } @@ -1858,7 +1843,7 @@ XCONSOLE (Vselected_console)); } - RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ + RETURN_NOT_REACHED (Qnil) /* suppress compiler warning */ } DEFUN ("default-boundp", Fdefault_boundp, 1, 1, 0, /* @@ -1866,9 +1851,9 @@ This is the value that is seen in buffers that do not have their own values for this variable. */ - (sym)) + (symbol)) { - return UNBOUNDP (default_value (sym)) ? Qnil : Qt; + return UNBOUNDP (default_value (symbol)) ? Qnil : Qt; } DEFUN ("default-value", Fdefault_value, 1, 1, 0, /* @@ -1877,11 +1862,11 @@ for this variable. The default value is meaningful for variables with local bindings in certain buffers. */ - (sym)) + (symbol)) { - Lisp_Object value = default_value (sym); - - return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (sym)) : value; + Lisp_Object value = default_value (symbol); + + return UNBOUNDP (value) ? Fsignal (Qvoid_variable, list1 (symbol)) : value; } DEFUN ("set-default", Fset_default, 2, 2, 0, /* @@ -1889,39 +1874,39 @@ The default value is seen in buffers that do not have their own values for this variable. */ - (sym, value)) + (symbol, value)) { Lisp_Object valcontents; - CHECK_SYMBOL (sym); + CHECK_SYMBOL (symbol); retry: - valcontents = XSYMBOL (sym)->value; + valcontents = XSYMBOL (symbol)->value; retry_2: if (!SYMBOL_VALUE_MAGIC_P (valcontents)) - return Fset (sym, value); + return Fset (symbol, value); switch (XSYMBOL_VALUE_MAGIC_TYPE (valcontents)) { case SYMVAL_LISP_MAGIC: - RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (sym, Qset_default, 1, + RETURN_IF_NOT_UNBOUND (maybe_call_magic_handler (symbol, Qset_default, 1, value)); valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; /* semi-change-o */ goto retry_2; case SYMVAL_VARALIAS: - sym = follow_varalias_pointers (sym, Qset_default); + symbol = follow_varalias_pointers (symbol, Qset_default); /* presto change-o! */ goto retry; case SYMVAL_CURRENT_BUFFER_FORWARD: - set_default_buffer_slot_variable (sym, value); + set_default_buffer_slot_variable (symbol, value); return value; case SYMVAL_SELECTED_CONSOLE_FORWARD: - set_default_console_slot_variable (sym, value); + set_default_console_slot_variable (symbol, value); return value; case SYMVAL_BUFFER_LOCAL: @@ -1935,50 +1920,48 @@ /* 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; - - args_left = args; - GCPRO1 (args); - - do + GET_LIST_LENGTH (args, nargs); + + if (nargs & 1) /* Odd number of arguments? */ + Fsignal (Qwrong_number_of_arguments, + list2 (Qsetq_default, make_int (nargs))); + + GCPRO1 (val); + + PROPERTY_LIST_LOOP (tail, symbol, val, args) { - val = Feval (Fcar (Fcdr (args_left))); - sym = Fcar (args_left); - Fset_default (sym, val); - args_left = Fcdr (Fcdr (args_left)); + val = Feval (val); + Fset_default (symbol, val); } - while (!NILP (args_left)); UNGCPRO; return val; @@ -2379,7 +2362,7 @@ Lisp_Object oldval = * (Lisp_Object *) (offset + (char *) XCONSOLE (Vconsole_defaults)); if (magicfun) - (magicfun) (variable, &oldval, Vselected_console, 0); + magicfun (variable, &oldval, Vselected_console, 0); *(Lisp_Object *) (offset + (char *) XCONSOLE (Vselected_console)) = oldval; XCONSOLE (Vselected_console)->local_var_flags &= ~mask; @@ -2390,7 +2373,6 @@ default: return variable; } - RETURN_NOT_REACHED(Qnil) /* suppress compiler warning */ } /* Used by specbind to determine what effects it might have. Returns: @@ -2464,10 +2446,7 @@ CHECK_SYMBOL (symbol); CHECK_BUFFER (buffer); value = symbol_value_in_buffer (symbol, buffer); - if (UNBOUNDP (value)) - return unbound_value; - else - return value; + return UNBOUNDP (value) ? unbound_value : value; } DEFUN ("symbol-value-in-console", Fsymbol_value_in_console, 2, 3, 0, /* @@ -2479,14 +2458,11 @@ CHECK_SYMBOL (symbol); CHECK_CONSOLE (console); value = symbol_value_in_console (symbol, console); - if (UNBOUNDP (value)) - return unbound_value; - else - return value; + return UNBOUNDP (value) ? unbound_value : value; } DEFUN ("built-in-variable-type", Fbuilt_in_variable_type, 1, 1, 0, /* -If SYM is a built-in variable, return info about this; else return nil. +If SYMBOL is a built-in variable, return info about this; else return nil. The returned info will be a symbol, one of `object' A simple built-in variable. @@ -2505,85 +2481,56 @@ `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)) + if (!SYMBOL_VALUE_MAGIC_P (valcontents)) + return Qnil; + + 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_SELECTED_CONSOLE_FORWARD: - return Qselected_console; - - case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: - return Qconst_selected_console; - - case SYMVAL_UNBOUND_MARKER: - return Qnil; - - default: - abort (); - } + case SYMVAL_LISP_MAGIC: + valcontents = XSYMBOL_VALUE_LISP_MAGIC (valcontents)->shadowed; + /* semi-change-o */ + goto retry_2; + + case SYMVAL_VARALIAS: + symbol = follow_varalias_pointers (symbol, 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_SELECTED_CONSOLE_FORWARD: return Qselected_console; + case SYMVAL_CONST_SELECTED_CONSOLE_FORWARD: return Qconst_selected_console; + case SYMVAL_UNBOUND_MARKER: return Qnil; + + default: + abort (); return Qnil; } - - return Qnil; } @@ -2636,7 +2583,7 @@ gets into its final form. I currently like the way everything is set up and it has all the features I want it to have, except for one: I really want to be able to have multiple nested handlers, -to implement an `advice'-like capabiility. This would allow, +to implement an `advice'-like capability. This would allow, for example, a clean way of implementing `debug-if-set' or `debug-if-referenced' and such. @@ -2945,7 +2892,7 @@ /* functions for working with variable aliases. */ -/* Follow the chain of variable aliases for OBJECT. Return the +/* Follow the chain of variable aliases for SYMBOL. Return the resulting symbol, whose value cell is guaranteed not to be a symbol-value-varalias. @@ -2973,36 +2920,32 @@ */ static Lisp_Object -follow_varalias_pointers (Lisp_Object object, +follow_varalias_pointers (Lisp_Object symbol, Lisp_Object follow_past_lisp_magic) { - Lisp_Object tortoise = object; - Lisp_Object hare = object; +#define VARALIAS_INDIRECTION_SUSPICION_LENGTH 16 + Lisp_Object tortoise, hare, val; + int count; /* quick out just in case */ - if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (object)->value)) - return object; - - /* based off of indirect_function() */ - for (;;) + if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (symbol)->value)) + return symbol; + + /* Compare implementation of indirect_function(). */ + for (hare = tortoise = symbol, count = 0; + val = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic), + SYMBOL_VALUE_VARALIAS_P (val); + hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (val)), + count++) { - Lisp_Object value; - - value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic); - if (!SYMBOL_VALUE_VARALIAS_P (value)) - break; - hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value)); - value = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic); - if (!SYMBOL_VALUE_VARALIAS_P (value)) - break; - hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (value)); - - value = fetch_value_maybe_past_magic (tortoise, follow_past_lisp_magic); - tortoise = symbol_value_varalias_aliasee - (XSYMBOL_VALUE_VARALIAS (value)); - + if (count < VARALIAS_INDIRECTION_SUSPICION_LENGTH) continue; + + if (count & 1) + tortoise = symbol_value_varalias_aliasee + (XSYMBOL_VALUE_VARALIAS (fetch_value_maybe_past_magic + (tortoise, follow_past_lisp_magic))); if (EQ (hare, tortoise)) - return Fsignal (Qcyclic_variable_indirection, list1 (object)); + return Fsignal (Qcyclic_variable_indirection, list1 (symbol)); } return hare; @@ -3147,13 +3090,13 @@ #ifndef Qnull_pointer /* C guarantees that Qnull_pointer will be initialized to all 0 bits, - so the following is a actually a no-op. */ + so the following is actually a no-op. */ XSETOBJ (Qnull_pointer, (enum Lisp_Type) 0, 0); #endif /* see comment in Fpurecopy() */ Vpure_uninterned_symbol_table = - make_lisp_hashtable (50, HASHTABLE_NONWEAK, HASHTABLE_EQ); + make_lisp_hash_table (50, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); staticpro (&Vpure_uninterned_symbol_table); Qnil = Fmake_symbol (make_pure_pname ((CONST Bufbyte *) "nil", 3, 1)); @@ -3215,17 +3158,16 @@ Fset (*location, *location); } -void -defsubr (struct Lisp_Subr *subr) +#ifdef DEBUG_XEMACS +/* Check that nobody spazzed writing a DEFUN. */ +static void +check_sane_subr (Lisp_Subr *subr, Lisp_Object sym) { - Lisp_Object sym = intern (subr_name (subr)); - -#ifdef DEBUG_XEMACS - /* Check that nobody spazzed writing a DEFUN. */ assert (subr->min_args >= 0); assert (subr->min_args <= SUBR_MAX_ARGS); - if (subr->max_args != MANY && subr->max_args != UNEVALLED) + if (subr->max_args != MANY && + subr->max_args != UNEVALLED) { /* Need to fix lisp.h and eval.c if SUBR_MAX_ARGS too small */ assert (subr->max_args <= SUBR_MAX_ARGS); @@ -3233,9 +3175,34 @@ } assert (UNBOUNDP (XSYMBOL (sym)->function)); -#endif /* DEBUG_XEMACS */ - - XSETSUBR (XSYMBOL (sym)->function, subr); +} +#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 (fun, subr); + XSYMBOL (sym)->function = Fcons (Qmacro, fun); } void @@ -3275,6 +3242,7 @@ defsymbol (&Qmakunbound, "makunbound"); defsymbol (&Qsymbol_value, "symbol-value"); defsymbol (&Qset, "set"); + defsymbol (&Qsetq_default, "setq-default"); defsymbol (&Qdefault_boundp, "default-boundp"); defsymbol (&Qdefault_value, "default-value"); defsymbol (&Qset_default, "set-default"); @@ -3313,6 +3281,7 @@ DEFSUBR (Ffboundp); DEFSUBR (Ffset); DEFSUBR (Fdefine_function); + Ffset (intern ("defalias"), intern ("define-function")); DEFSUBR (Fsetplist); DEFSUBR (Fsymbol_value_in_buffer); DEFSUBR (Fsymbol_value_in_console); @@ -3334,29 +3303,29 @@ 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); - - /* Check that magic points somewhere we can represent as a Lisp pointer */ + Lisp_Object sym, kludge; + + /* Check that `magic' points somewhere we can represent as a Lisp pointer */ XSETOBJ (kludge, Lisp_Type_Record, magic); - if (magic != (CONST void *) XPNTR (kludge)) + if ((void *)magic != (void*) XPNTR (kludge)) { /* This might happen on DATA_SEG_BITS machines. */ /* abort (); */ /* Copy it to somewhere which is representable. */ - void *f = xmalloc (sizeof_magic); - memcpy (f, magic, sizeof_magic); - XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, f); + struct symbol_value_forward *p = xnew (struct symbol_value_forward); + memcpy (p, magic, sizeof *magic); + magic = p; } - else - XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic); + + sym = Fintern (make_pure_pname ((CONST Bufbyte *) symbol_name, + strlen (symbol_name), + 1), + Qnil); + XSETOBJ (XSYMBOL (sym)->value, Lisp_Type_Record, magic); } void diff -r 76b7d63099ad -r 8626e4521993 src/symeval.h --- a/src/symeval.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/symeval.h Mon Aug 13 11:07:10 2007 +0200 @@ -99,8 +99,9 @@ struct symbol_value_forward { struct symbol_value_magic magic; - /* void *forward; -- use magic.lcheader.next instead */ - /* Function controlling magic behavior of this forward variable. + + /* `magicfun' is a function controlling the magic behavior of this + forward variable. SYM is the symbol being operated on (read, set, etc.); @@ -122,20 +123,15 @@ that the only console-local variables currently existing are built-in ones, because others can't be created.) - FLAGS gives more information about the operation being - performed. + FLAGS gives more information about the operation being performed. - The return value indicates what the magic function actually - did. + The return value indicates what the magic function actually did. Currently FLAGS and the return value are not used. This function is only called when the value of a forward variable is about to be changed. Note that this can occur explicitly through a call to `set', `setq', `set-default', or `setq-default', - or implicitly by the current buffer being changed. - - */ - + or implicitly by the current buffer being changed. */ int (*magicfun) (Lisp_Object sym, Lisp_Object *val, Lisp_Object in_object, int flags); }; @@ -271,10 +267,19 @@ #define symbol_value_varalias_aliasee(m) ((m)->aliasee) #define symbol_value_varalias_shadowed(m) ((m)->shadowed) -/* DEFSUBR (Fname); - is how we define the symbol for function `Fname' at start-up time. */ +/* To define a Lisp primitive function using a C function `Fname', do this: + DEFUN ("name, Fname, ...); // at top level in foo.c + DEFSUBR (Fname); // in syms_of_foo(); +*/ +void defsubr (Lisp_Subr *); #define DEFSUBR(Fname) defsubr (&S##Fname) -void defsubr (struct Lisp_Subr *); + +/* To define a Lisp primitive macro using a C function `Fname', do this: + DEFUN ("name, Fname, ...); // at top level in foo.c + DEFSUBR_MACRO (Fname); // in syms_of_foo(); +*/ +void defsubr_macro (Lisp_Subr *); +#define DEFSUBR_MACRO(Fname) defsubr_macro (&S##Fname) void defsymbol (Lisp_Object *location, CONST char *name); @@ -286,7 +291,7 @@ /* Macros we use to define forwarded Lisp variables. These are used in the syms_of_FILENAME functions. */ -void defvar_mumble (CONST char *names, CONST void *magic, size_t sizeof_magic); +void defvar_magic (CONST char *symbol_name, CONST struct symbol_value_forward *magic); #ifdef USE_INDEXED_LRECORD_IMPLEMENTATION # define symbol_value_forward_lheader_initializer { 1, 0, 0 } @@ -295,44 +300,39 @@ { lrecord_symbol_value_forward } #endif -#define DEFVAR_HEADER(lname, c_location, forward_type) \ - DEFVAR_MAGIC_HEADER (lname, c_location, forward_type, 0) - -#define DEFVAR_MAGIC_HEADER(lname, c_location, forward_type, magicfun) do { \ - static CONST struct symbol_value_forward I_hate_C \ +#define DEFVAR_SYMVAL_FWD(lname, c_location, forward_type, magicfun) do { \ + static CONST_IF_NOT_DEBUG struct symbol_value_forward I_hate_C \ = { { { symbol_value_forward_lheader_initializer, \ - (struct lcrecord_header *) (c_location), 69 }, \ + (struct lcrecord_header *) (c_location), 69 }, \ forward_type }, magicfun }; \ - defvar_mumble ((lname), &I_hate_C, sizeof (I_hate_C)); \ + defvar_magic ((lname), &I_hate_C); \ } while (0) -#define DEFVAR_HEADER_GCPRO(lname, c_location, symbol_value_type) do { \ - DEFVAR_HEADER (lname, c_location, symbol_value_type); \ - staticpro (c_location); \ +#define DEFVAR_SYMVAL_FWD_OBJECT(lname, c_location, forward_type, magicfun) do{ \ + DEFVAR_SYMVAL_FWD (lname, c_location, forward_type, magicfun); \ + staticpro (c_location); \ + if (EQ (*c_location, Qnull_pointer)) *c_location = Qnil; \ } while (0) -#define DEFVAR_LISP(lname, c_location) \ - DEFVAR_HEADER_GCPRO (lname, c_location, SYMVAL_OBJECT_FORWARD) +#define DEFVAR_LISP(lname, c_location) \ + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_OBJECT_FORWARD, 0) #define DEFVAR_CONST_LISP(lname, c_location) \ - DEFVAR_HEADER_GCPRO (lname, c_location, SYMVAL_CONST_OBJECT_FORWARD) + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_CONST_OBJECT_FORWARD, 0) #define DEFVAR_SPECIFIER(lname, c_location) \ - DEFVAR_HEADER_GCPRO (lname, c_location, SYMVAL_CONST_SPECIFIER_FORWARD) + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_CONST_SPECIFIER_FORWARD, 0) #define DEFVAR_INT(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_FIXNUM_FORWARD) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_FIXNUM_FORWARD, 0) #define DEFVAR_CONST_INT(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_CONST_FIXNUM_FORWARD) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_CONST_FIXNUM_FORWARD, 0) #define DEFVAR_BOOL(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_BOOLEAN_FORWARD) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_BOOLEAN_FORWARD, 0) #define DEFVAR_CONST_BOOL(lname, c_location) \ - DEFVAR_HEADER (lname, c_location, SYMVAL_CONST_BOOLEAN_FORWARD) - -#define DEFVAR_LISP_MAGIC(lname, c_location, magicfun) do { \ - DEFVAR_MAGIC_HEADER (lname, c_location, SYMVAL_OBJECT_FORWARD, magicfun); \ - staticpro (c_location); \ -} while (0) + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_CONST_BOOLEAN_FORWARD, 0) +#define DEFVAR_LISP_MAGIC(lname, c_location, magicfun) \ + DEFVAR_SYMVAL_FWD_OBJECT (lname, c_location, SYMVAL_OBJECT_FORWARD, magicfun); #define DEFVAR_INT_MAGIC(lname, c_location, magicfun) \ - DEFVAR_MAGIC_HEADER (lname, c_location, SYMVAL_FIXNUM_FORWARD, magicfun); + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_FIXNUM_FORWARD, magicfun); #define DEFVAR_BOOL_MAGIC(lname, c_location, magicfun) \ - DEFVAR_MAGIC_HEADER (lname, c_location, SYMVAL_BOOLEAN_FORWARD, magicfun); + DEFVAR_SYMVAL_FWD (lname, c_location, SYMVAL_BOOLEAN_FORWARD, magicfun); #endif /* _XEMACS_SYMEVAL_H_ */ diff -r 76b7d63099ad -r 8626e4521993 src/symsinit.h --- a/src/symsinit.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/symsinit.h Mon Aug 13 11:07:10 2007 +0200 @@ -186,7 +186,7 @@ void structure_type_create_chartab (void); void structure_type_create_faces (void); void structure_type_create_rangetab (void); -void structure_type_create_hashtable (void); +void structure_type_create_hash_table (void); /* Initialize the image instantiator types (dump-time only). */ diff -r 76b7d63099ad -r 8626e4521993 src/syntax.c --- a/src/syntax.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/syntax.c Mon Aug 13 11:07:10 2007 +0200 @@ -27,8 +27,6 @@ #include "lisp.h" #include "buffer.h" -#include "commands.h" -#include "insdel.h" #include "syntax.h" /* Here is a comment from Ken'ichi HANDA @@ -396,10 +394,12 @@ } DEFUN ("forward-word", Fforward_word, 1, 2, "_p", /* -Move point forward ARG words (backward if ARG is negative). +Move point forward COUNT words (backward if COUNT is negative). Normally returns t. If an edge of the buffer is reached, point is left there and nil is returned. + +Optional argument BUFFER defaults to the current buffer. */ (count, buffer)) { diff -r 76b7d63099ad -r 8626e4521993 src/syntax.h --- a/src/syntax.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/syntax.h Mon Aug 13 11:07:10 2007 +0200 @@ -89,8 +89,7 @@ INLINE int WORD_SYNTAX_P (struct Lisp_Char_Table *table, Emchar c) { - int syncode = SYNTAX (table, c); - return syncode == Sword; + return SYNTAX (table, c) == Sword; } /* OK, here's a graphic diagram of the format of the syntax values: diff -r 76b7d63099ad -r 8626e4521993 src/sysdep.c --- a/src/sysdep.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sysdep.c Mon Aug 13 11:07:10 2007 +0200 @@ -212,11 +212,7 @@ } #endif -#ifdef O_NONBLOCK /* The POSIX way */ fcntl (fd, F_SETFL, O_NONBLOCK); -#elif defined (O_NDELAY) - fcntl (fd, F_SETFL, O_NDELAY); -#endif /* O_NONBLOCK */ } #if defined (NO_SUBPROCESSES) @@ -456,8 +452,8 @@ s.main.c_lflag |= ICANON; /* Enable erase/kill and eof processing */ s.main.c_cc[VEOF] = 04; /* ensure that EOF is Control-D */ - s.main.c_cc[VERASE] = CDISABLE; /* disable erase processing */ - s.main.c_cc[VKILL] = CDISABLE; /* disable kill processing */ + s.main.c_cc[VERASE] = _POSIX_VDISABLE; /* disable erase processing */ + s.main.c_cc[VKILL] = _POSIX_VDISABLE; /* disable kill processing */ #ifdef HPUX s.main.c_cflag = (s.main.c_cflag & ~CBAUD) | B9600; /* baud rate sanity */ @@ -485,12 +481,12 @@ #else /* no TIOCGPGRP or no TIOCGLTC or no TIOCGETC */ /* TTY `special characters' work better as signals, so disable character forms */ - s.main.c_cc[VQUIT] = CDISABLE; - s.main.c_cc[VINTR] = CDISABLE; - s.main.c_cc[VSUSP] = CDISABLE; + s.main.c_cc[VQUIT] = _POSIX_VDISABLE; + s.main.c_cc[VINTR] = _POSIX_VDISABLE; + s.main.c_cc[VSUSP] = _POSIX_VDISABLE; s.main.c_lflag &= ~ISIG; #endif /* no TIOCGPGRP or no TIOCGLTC or no TIOCGETC */ - s.main.c_cc[VEOL] = CDISABLE; + s.main.c_cc[VEOL] = _POSIX_VDISABLE; #if defined (CBAUD) /* ### This is not portable. ### POSIX does not specify CBAUD, and 4.4BSD does not have it. @@ -749,7 +745,7 @@ else return (Bufbyte) t.c_cc[VEOF]; #endif - return t.c_cc[VEOF] == CDISABLE ? ctrl_d : (Bufbyte) t.c_cc[VEOF]; + return t.c_cc[VEOF] == _POSIX_VDISABLE ? ctrl_d : (Bufbyte) t.c_cc[VEOF]; } #else /* ! HAVE_TERMIOS */ /* On Berkeley descendants, the following IOCTL's retrieve the @@ -1534,51 +1530,51 @@ } else { - tty.main.c_cc[VINTR] = CDISABLE; - tty.main.c_cc[VQUIT] = CDISABLE; + tty.main.c_cc[VINTR] = _POSIX_VDISABLE; + tty.main.c_cc[VQUIT] = _POSIX_VDISABLE; } tty.main.c_cc[VMIN] = 1; /* Input should wait for at least 1 char */ tty.main.c_cc[VTIME] = 0; /* no matter how long that takes. */ #ifdef VSWTCH - tty.main.c_cc[VSWTCH] = CDISABLE; /* Turn off shell layering use - of C-z */ + tty.main.c_cc[VSWTCH] = _POSIX_VDISABLE; /* Turn off shell layering use + of C-z */ #endif /* VSWTCH */ /* There was some conditionalizing here on (mips or TCATTR), but I think that's wrong. There was one report of C-y (DSUSP) not being disabled on HP9000s700 systems, and this might fix it. */ #ifdef VSUSP - tty.main.c_cc[VSUSP] = CDISABLE;/* Turn off mips handling of C-z. */ + tty.main.c_cc[VSUSP] = _POSIX_VDISABLE; /* Turn off mips handling of C-z. */ #endif /* VSUSP */ #ifdef V_DSUSP - tty.main.c_cc[V_DSUSP] = CDISABLE; /* Turn off mips handling of C-y. */ + tty.main.c_cc[V_DSUSP] = _POSIX_VDISABLE; /* Turn off mips handling of C-y. */ #endif /* V_DSUSP */ #ifdef VDSUSP /* Some systems have VDSUSP, some have V_DSUSP. */ - tty.main.c_cc[VDSUSP] = CDISABLE; + tty.main.c_cc[VDSUSP] = _POSIX_VDISABLE; #endif /* VDSUSP */ #ifdef VLNEXT - tty.main.c_cc[VLNEXT] = CDISABLE; + tty.main.c_cc[VLNEXT] = _POSIX_VDISABLE; #endif /* VLNEXT */ #ifdef VREPRINT - tty.main.c_cc[VREPRINT] = CDISABLE; + tty.main.c_cc[VREPRINT] = _POSIX_VDISABLE; #endif /* VREPRINT */ #ifdef VWERASE - tty.main.c_cc[VWERASE] = CDISABLE; + tty.main.c_cc[VWERASE] = _POSIX_VDISABLE; #endif /* VWERASE */ #ifdef VDISCARD - tty.main.c_cc[VDISCARD] = CDISABLE; + tty.main.c_cc[VDISCARD] = _POSIX_VDISABLE; #endif /* VDISCARD */ #ifdef VSTART - tty.main.c_cc[VSTART] = CDISABLE; + tty.main.c_cc[VSTART] = _POSIX_VDISABLE; #endif /* VSTART */ #ifdef VSTRT - tty.main.c_cc[VSTRT] = CDISABLE; /* called VSTRT on some systems */ + tty.main.c_cc[VSTRT] = _POSIX_VDISABLE; /* called VSTRT on some systems */ #endif /* VSTART */ #ifdef VSTOP - tty.main.c_cc[VSTOP] = CDISABLE; + tty.main.c_cc[VSTOP] = _POSIX_VDISABLE; #endif /* VSTOP */ #ifdef SET_LINE_DISCIPLINE - /* Need to explicitely request TERMIODISC line discipline or + /* Need to explicitly request TERMIODISC line discipline or Ultrix's termios does not work correctly. */ tty.main.c_line = SET_LINE_DISCIPLINE; #endif @@ -2072,7 +2068,6 @@ /* limits of text/data segments */ /************************************************************************/ -/* Note that VMS compiler won't accept defined (CANNOT_DUMP). */ #ifndef CANNOT_DUMP #define NEED_STARTS #endif @@ -2137,7 +2132,7 @@ * at least on UniPlus, is temacs will have to be made unshared so * that text and data are contiguous. Then once loadup is complete, * unexec will produce a shared executable where the data can be - * at the normal shared text boundry and the startofdata variable + * at the normal shared text boundary and the startofdata variable * will be patched by unexec to the correct value. * */ @@ -2594,7 +2589,8 @@ { int rtnval; while ((rtnval = open (path, oflag, mode)) == -1 - && (errno == EINTR)); + && (errno == EINTR)) + DO_NOTHING; return rtnval; } #else @@ -2779,7 +2775,8 @@ #elif defined (INTERRUPTIBLE_OPEN) { FILE *rtnval; - while (!(rtnval = fopen (path, type)) && (errno == EINTR)); + while (!(rtnval = fopen (path, type)) && (errno == EINTR)) + DO_NOTHING; return rtnval; } #else @@ -3682,7 +3679,7 @@ int fd; /* file descriptor for read */ struct stat sbuf; /* result of fstat */ - fd = sys_open (filename, 0); + fd = sys_open (filename, O_RDONLY); if (fd < 0) return 0; @@ -3799,24 +3796,24 @@ { case -1: /* Error in fork() */ - return (-1); /* Errno is set already */ + return -1; /* Errno is set already */ case 0: /* Child process */ { /* - * Cheap hack to set mode of new directory. Since this - * child process is going away anyway, we zap its umask. - * ####, this won't suffice to set SUID, SGID, etc. on this - * directory. Does anybody care? - */ + * Cheap hack to set mode of new directory. Since this + * child process is going away anyway, we zap its umask. + * ####, this won't suffice to set SUID, SGID, etc. on this + * directory. Does anybody care? + */ status = umask (0); /* Get current umask */ status = umask (status | (0777 & ~dmode)); /* Set for mkdir */ - fd = sys_open ("/dev/null", 2); + fd = sys_open ("/dev/null", O_RDWR); if (fd >= 0) { - dup2 (fd, 0); - dup2 (fd, 1); - dup2 (fd, 2); + if (fd != STDIN_FILENO) dup2 (fd, STDIN_FILENO); + if (fd != STDOUT_FILENO) dup2 (fd, STDOUT_FILENO); + if (fd != STDERR_FILENO) dup2 (fd, STDERR_FILENO); } execl ("/bin/mkdir", "mkdir", dpath, (char *) 0); _exit (-1); /* Can't exec /bin/mkdir */ @@ -3857,12 +3854,12 @@ return (-1); /* Errno is set already */ case 0: /* Child process */ - fd = sys_open("/dev/null", 2); + fd = sys_open("/dev/null", O_RDWR); if (fd >= 0) { - dup2 (fd, 0); - dup2 (fd, 1); - dup2 (fd, 2); + if (fd != STDIN_FILENO) dup2 (fd, STDIN_FILENO); + if (fd != STDOUT_FILENO) dup2 (fd, STDOUT_FILENO); + if (fd != STDERR_FILENO) dup2 (fd, STDERR_FILENO); } execl ("/bin/rmdir", "rmdir", dpath, (char *) 0); _exit (-1); /* Can't exec /bin/mkdir */ @@ -3871,7 +3868,8 @@ wait_for_termination (cpid); } - if (synch_process_death != 0 || synch_process_retcode != 0) + if (synch_process_death != 0 || + synch_process_retcode != 0) { errno = EIO; /* We don't know why, but */ return -1; /* /bin/rmdir failed */ diff -r 76b7d63099ad -r 8626e4521993 src/sysdep.h --- a/src/sysdep.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sysdep.h Mon Aug 13 11:07:10 2007 +0200 @@ -59,7 +59,7 @@ /* Suspend the Emacs process; give terminal to its superior. */ void sys_suspend (void); -/* Suspend a process if possible; give termianl to its superior. */ +/* Suspend a process if possible; give terminal to its superior. */ void sys_suspend_process (int process); void request_sigio (void); diff -r 76b7d63099ad -r 8626e4521993 src/sysdll.c --- a/src/sysdll.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sysdll.c Mon Aug 13 11:07:10 2007 +0200 @@ -23,10 +23,6 @@ #include #endif -#include -#include -#include -#include #include "sysdll.h" /* This whole file is conditional upon HAVE_DLL */ diff -r 76b7d63099ad -r 8626e4521993 src/sysfile.h --- a/src/sysfile.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sysfile.h Mon Aug 13 11:07:10 2007 +0200 @@ -55,6 +55,12 @@ #include #endif +#ifndef STDERR_FILENO +#define STDIN_FILENO 0 +#define STDOUT_FILENO 1 +#define STDERR_FILENO 2 +#endif + #ifndef O_RDONLY #define O_RDONLY 0 #endif @@ -116,6 +122,14 @@ #endif #endif +#ifndef O_NONBLOCK +#ifdef O_NDELAY +#define O_NONBLOCK O_NDELAY +#else +#define O_NONBLOCK 04000 +#endif +#endif + /* if system does not have symbolic links, it does not have lstat. In that case, use ordinary stat instead. */ diff -r 76b7d63099ad -r 8626e4521993 src/sysproc.h --- a/src/sysproc.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/sysproc.h Mon Aug 13 11:07:10 2007 +0200 @@ -96,11 +96,6 @@ #endif /* no FD_SET */ -#ifdef EMACS_BTL -int cadillac_stop_logging (); -int cadillac_start_logging (); -#endif - int poll_fds_for_input (SELECT_TYPE mask); #ifdef MSDOS diff -r 76b7d63099ad -r 8626e4521993 src/syssignal.h --- a/src/syssignal.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/syssignal.h Mon Aug 13 11:07:10 2007 +0200 @@ -112,30 +112,30 @@ #define EMACS_BLOCK_SIGNAL(sig) do \ { \ - sigset_t _mask; \ - sigemptyset (&_mask); \ - sigaddset (&_mask, sig); \ - sigprocmask (SIG_BLOCK, &_mask, NULL); \ + sigset_t ES_mask; \ + sigemptyset (&ES_mask); \ + sigaddset (&ES_mask, sig); \ + sigprocmask (SIG_BLOCK, &ES_mask, NULL); \ } while (0) #define EMACS_UNBLOCK_SIGNAL(sig) do \ { \ - sigset_t _mask; \ - sigemptyset (&_mask); \ - sigaddset (&_mask, sig); \ - sigprocmask (SIG_UNBLOCK, &_mask, NULL); \ + sigset_t ES_mask; \ + sigemptyset (&ES_mask); \ + sigaddset (&ES_mask, sig); \ + sigprocmask (SIG_UNBLOCK, &ES_mask, NULL); \ } while (0) #define EMACS_UNBLOCK_ALL_SIGNALS() do \ { \ - sigset_t _mask; \ - sigemptyset (&_mask); \ - sigprocmask (SIG_SETMASK, &_mask, NULL); \ + sigset_t ES_mask; \ + sigemptyset (&ES_mask); \ + sigprocmask (SIG_SETMASK, &ES_mask, NULL); \ } while (0) #define EMACS_WAIT_FOR_SIGNAL(sig) do \ { \ - sigset_t _mask; \ - sigprocmask (0, NULL, &_mask); \ - sigdelset (&_mask, sig); \ - sigsuspend (&_mask); \ + sigset_t ES_mask; \ + sigprocmask (0, NULL, &ES_mask); \ + sigdelset (&ES_mask, sig); \ + sigsuspend (&ES_mask); \ } while (0) #define EMACS_REESTABLISH_SIGNAL(sig, handler) @@ -159,8 +159,8 @@ #define EMACS_UNBLOCK_ALL_SIGNALS() sigsetmask (0) #define EMACS_WAIT_FOR_SIGNAL(sig) do \ { \ - int _mask = sigblock (0); \ - sigpause (_mask & ~sigmask (sig)); \ + int ES_mask = sigblock (0); \ + sigpause (ES_mask & ~sigmask (sig)); \ } while (0) #define EMACS_REESTABLISH_SIGNAL(sig, handler) diff -r 76b7d63099ad -r 8626e4521993 src/systty.h --- a/src/systty.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/systty.h Mon Aug 13 11:07:10 2007 +0200 @@ -53,6 +53,10 @@ /* Include the proper files. */ +#ifdef HAVE_UNISTD_H +#include +#endif + /* XEmacs: TERMIOS is mo' better than TERMIO so we use it if it's there. Since TERMIO is backward-compatibility stuff if both it and TERMIOS exist, it's more likely to be broken. */ @@ -193,10 +197,6 @@ #undef TIOCSWINSZ #endif -#ifdef BROKEN_O_NONBLOCK /* XEmacs addition */ -# undef O_NONBLOCK -#endif /* BROKEN_O_NONBLOCK */ - /* On TERMIOS systems, the tcmumbleattr calls take care of these parameters, and it's a bad idea to use them (on AIX, it makes the tty hang for a long time). */ @@ -214,19 +214,16 @@ /* ----------------------------------------------------- */ /* 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! */ + in a system-independent manner. + We use the POSIX standard way to do this, and emulate on other systems. */ -#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 */ +#ifndef _POSIX_VDISABLE +# if defined CDEL +# define _POSIX_VDISABLE CDEL +# else +# define _POSIX_VDISABLE 255 +# endif +#endif /* ! _POSIX_VDISABLE */ /* ----------------------------------------------------- */ diff -r 76b7d63099ad -r 8626e4521993 src/toolbar-msw.c --- a/src/toolbar-msw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/toolbar-msw.c Mon Aug 13 11:07:10 2007 +0200 @@ -87,7 +87,7 @@ /* hmm what do we generate an id based on */ int id = TOOLBAR_ITEM_ID_BITS (internal_hash (button->callback, 0)); while (!NILP (Fgethash (make_int (id), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f), Qnil))) + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f), Qnil))) { id = TOOLBAR_ITEM_ID_BITS (id + 1); } @@ -105,14 +105,14 @@ { TBBUTTON info; - /* delete the buttons and remove the command from the hashtable*/ + /* Delete the buttons and remove the command from the hash table*/ i = SendMessage (toolbarwnd, TB_BUTTONCOUNT, 0, 0); for (i--; i >= 0; i--) { SendMessage (toolbarwnd, TB_GETBUTTON, (WPARAM)i, (LPARAM)&info); Fremhash(make_int(info.idCommand), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE(f)); + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE(f)); SendMessage (toolbarwnd, TB_DELETEBUTTON, (WPARAM)i, 0); } @@ -262,7 +262,7 @@ if (IMAGE_INSTANCE_PIXMAP_TYPE_P (p)) { - /* we are going to honour the toolbar settings + /* we are going to honor the toolbar settings and resize the bitmaps accordingly if they are too big. If they are too small we leave them and pad the difference - unless a different size @@ -293,7 +293,7 @@ { xfree (button_tbl); if (ilist) ImageList_Destroy (ilist); - signal_simple_error ("couldn't resize pixmap", + signal_simple_error ("Couldn't resize pixmap", instance); } /* we don't care if the mask fails */ @@ -316,7 +316,7 @@ nbuttons, nbuttons * 2 ))) { xfree (button_tbl); - signal_simple_error ("couldn't create image list", + signal_simple_error ("Couldn't create image list", instance); } @@ -343,7 +343,7 @@ } Fputhash (make_int (tbbutton->idCommand), - button, FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f)); + button, FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f)); } /* now fix up the button size */ @@ -582,7 +582,7 @@ mswindows_get_toolbar_button_text ( struct frame* f, int command_id ) { Lisp_Object button = Fgethash (make_int (command_id), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f), Qnil); + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f), Qnil); if (!NILP (button)) { @@ -605,7 +605,7 @@ Lisp_Object button, data, fn, arg, frame; button = Fgethash (make_int (id), - FRAME_MSWINDOWS_TOOLBAR_HASHTABLE (f), Qnil); + FRAME_MSWINDOWS_TOOLBAR_HASH_TABLE (f), Qnil); if (NILP (button)) return Qnil; diff -r 76b7d63099ad -r 8626e4521993 src/toolbar-x.c --- a/src/toolbar-x.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/toolbar-x.c Mon Aug 13 11:07:10 2007 +0200 @@ -29,10 +29,8 @@ #include "console-x.h" #include "glyphs-x.h" #include "objects-x.h" -#include "xgccache.h" #include "EmacsFrame.h" #include "EmacsFrameP.h" -#include "EmacsManager.h" #include "faces.h" #include "frame.h" diff -r 76b7d63099ad -r 8626e4521993 src/toolbar.c --- a/src/toolbar.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/toolbar.c Mon Aug 13 11:07:10 2007 +0200 @@ -59,17 +59,17 @@ static Lisp_Object mark_toolbar_button (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - struct toolbar_button *data = (struct toolbar_button *) XPNTR (obj); - ((markobj) (data->next)); - ((markobj) (data->frame)); - ((markobj) (data->up_glyph)); - ((markobj) (data->down_glyph)); - ((markobj) (data->disabled_glyph)); - ((markobj) (data->cap_up_glyph)); - ((markobj) (data->cap_down_glyph)); - ((markobj) (data->cap_disabled_glyph)); - ((markobj) (data->callback)); - ((markobj) (data->enabled_p)); + struct toolbar_button *data = XTOOLBAR_BUTTON (obj); + markobj (data->next); + markobj (data->frame); + markobj (data->up_glyph); + markobj (data->down_glyph); + markobj (data->disabled_glyph); + markobj (data->cap_up_glyph); + markobj (data->cap_down_glyph); + markobj (data->cap_disabled_glyph); + markobj (data->callback); + markobj (data->enabled_p); return data->help_string; } @@ -741,10 +741,10 @@ /* We're not officially "in redisplay", so we still have a chance to re-layout toolbars and windows. This is done here, because toolbar is the only thing which currently might - necesseritate this layout, as it is outside any windows. We + necessitate this layout, as it is outside any windows. We take care not to change size if toolbar geometry is really unchanged, as it will hose windows whose pixsizes are not - multiple of character sizes */ + multiple of character sizes. */ for (pos = 0; pos < 4; pos++) if (FRAME_REAL_TOOLBAR_SIZE (f, pos) @@ -894,30 +894,27 @@ } } -#define CHECK_TOOLBAR(pos) \ - do \ +#define CHECK_TOOLBAR(pos) do { \ + if (FRAME_REAL_##pos##_VISIBLE (f)) \ { \ + int x, y, width, height, vert; \ + \ get_toolbar_coords (f, pos, &x, &y, &width, &height, &vert, 0); \ if ((x_coord >= x) && (x_coord < (x + width))) \ { \ if ((y_coord >= y) && (y_coord < (y + height))) \ return FRAME_TOOLBAR_BUTTONS (f, pos); \ } \ - } while (0) + } \ +} while (0) static Lisp_Object toolbar_buttons_at_pixpos (struct frame *f, int x_coord, int y_coord) { - int x, y, width, height, vert; - - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (TOP_TOOLBAR); - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (BOTTOM_TOOLBAR); - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (LEFT_TOOLBAR); - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - CHECK_TOOLBAR (RIGHT_TOOLBAR); + CHECK_TOOLBAR (TOP_TOOLBAR); + CHECK_TOOLBAR (BOTTOM_TOOLBAR); + CHECK_TOOLBAR (LEFT_TOOLBAR); + CHECK_TOOLBAR (RIGHT_TOOLBAR); return Qnil; } @@ -931,9 +928,6 @@ { Lisp_Object buttons = toolbar_buttons_at_pixpos (f, x_coord, y_coord); - if (NILP (buttons)) - return Qnil; - while (!NILP (buttons)) { struct toolbar_button *tb = XTOOLBAR_BUTTON (buttons); @@ -953,7 +947,7 @@ buttons = tb->next; } - /* We must be over a blank in the toolbar. */ + /* We are not over a toolbar or we are over a blank in the toolbar. */ return Qnil; } @@ -964,13 +958,10 @@ DEFINE_SPECIFIER_TYPE (toolbar); -#define CTB_ERROR(msg) \ - do \ - { \ - maybe_signal_simple_error (msg, button, Qtoolbar, errb); \ - RETURN__ Qnil; \ - } \ - while (0) +#define CTB_ERROR(msg) do { \ + maybe_signal_simple_error (msg, button, Qtoolbar, errb); \ + RETURN_SANS_WARNINGS Qnil; \ +} while (0) /* Returns Q_style if key was :style, Qt if ok otherwise, Qnil if error. */ static Lisp_Object @@ -979,7 +970,7 @@ { if (!KEYWORDP (key)) { - maybe_signal_simple_error_2 ("not a keyword", key, button, Qtoolbar, + maybe_signal_simple_error_2 ("Not a keyword", key, button, Qtoolbar, errb); return Qnil; } @@ -990,7 +981,7 @@ && !EQ (val, Q3D) && !EQ (val, Q2d) && !EQ (val, Q3d)) - CTB_ERROR ("unrecognized toolbar blank style"); + CTB_ERROR ("Unrecognized toolbar blank style"); return Q_style; } @@ -1139,18 +1130,18 @@ return; if (!CONSP (instantiator)) - signal_simple_error ("toolbar spec must be list or nil", instantiator); + signal_simple_error ("Toolbar spec must be list or nil", instantiator); for (rest = instantiator; !NILP (rest); rest = XCDR (rest)) { if (!CONSP (rest)) - signal_simple_error ("bad list in toolbar spec", instantiator); + signal_simple_error ("Bad list in toolbar spec", instantiator); if (NILP (XCAR (rest))) { if (pushright_seen) error - ("more than one partition (nil) in instantiator description"); + ("More than one partition (nil) in instantiator description"); else pushright_seen = 1; } @@ -1200,7 +1191,7 @@ Lisp_Object oldval) { /* This could be smarter but I doubt that it would make any - noticable difference given the infrequency with which this is + noticeable difference given the infrequency with which this is probably going to be called. */ MARK_TOOLBAR_CHANGED; @@ -1272,7 +1263,7 @@ Lisp_Object oldval) { /* This could be smarter but I doubt that it would make any - noticable difference given the infrequency with which this is + noticeable difference given the infrequency with which this is probably going to be called. */ MARK_TOOLBAR_CHANGED; } diff -r 76b7d63099ad -r 8626e4521993 src/toolbar.h --- a/src/toolbar.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/toolbar.h Mon Aug 13 11:07:10 2007 +0200 @@ -25,9 +25,9 @@ #ifndef _XEMACS_TOOLBAR_H_ #define _XEMACS_TOOLBAR_H_ -#include "specifier.h" +#ifdef HAVE_TOOLBARS -#ifdef HAVE_TOOLBARS +#include "specifier.h" #define FRAME_TOOLBAR_BUTTONS(frame, pos) \ ((frame)->toolbar_buttons[pos]) @@ -65,7 +65,7 @@ int dirty; /* is this button in a left or right toolbar? */ int vertical; - /* border_width when this button was layed out */ + /* border_width when this button was laid out */ int border_width; }; diff -r 76b7d63099ad -r 8626e4521993 src/tooltalk.c --- a/src/tooltalk.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/tooltalk.c Mon Aug 13 11:07:10 2007 +0200 @@ -153,7 +153,7 @@ static Lisp_Object mark_tooltalk_message (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - (markobj) (XTOOLTALK_MESSAGE (obj)->callback); + markobj (XTOOLTALK_MESSAGE (obj)->callback); return XTOOLTALK_MESSAGE (obj)->plist_sym; } @@ -169,7 +169,7 @@ error ("printing unreadable object #", p->header.uid); - sprintf (buf, "#", p->m, p->header.uid); + sprintf (buf, "#", (long) (p->m), p->header.uid); write_c_string (buf, printcharfun); } @@ -227,7 +227,7 @@ static Lisp_Object mark_tooltalk_pattern (Lisp_Object obj, void (*markobj) (Lisp_Object)) { - (markobj) (XTOOLTALK_PATTERN (obj)->callback); + markobj (XTOOLTALK_PATTERN (obj)->callback); return XTOOLTALK_PATTERN (obj)->plist_sym; } @@ -243,7 +243,7 @@ error ("printing unreadable object #", p->header.uid); - sprintf (buf, "#", p->p, p->header.uid); + sprintf (buf, "#", (long) (p->p), p->header.uid); write_c_string (buf, printcharfun); } @@ -673,7 +673,7 @@ (XTOOLTALK_MESSAGE (message_)->plist_sym)); else - signal_simple_error ("invalid value for `get-tooltalk-message-attribute'", + signal_simple_error ("Invalid value for `get-tooltalk-message-attribute'", attribute); return Qnil; @@ -834,7 +834,7 @@ return Fput (XTOOLTALK_MESSAGE (message_)->plist_sym, argn, value); } else - signal_simple_error ("invalid value for `set-tooltalk-message-attribute'", + signal_simple_error ("Invalid value for `set-tooltalk-message-attribute'", attribute); return Qnil; } @@ -1474,8 +1474,8 @@ staticpro (&Vtooltalk_message_gcpro); staticpro (&Vtooltalk_pattern_gcpro); - Vtooltalk_message_gcpro = make_lisp_hashtable (10, HASHTABLE_NONWEAK, - HASHTABLE_EQ); - Vtooltalk_pattern_gcpro = make_lisp_hashtable (10, HASHTABLE_NONWEAK, - HASHTABLE_EQ); + Vtooltalk_message_gcpro = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); + Vtooltalk_pattern_gcpro = + make_lisp_hash_table (10, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); } diff -r 76b7d63099ad -r 8626e4521993 src/tooltalk.doc --- a/src/tooltalk.doc Mon Aug 13 11:06:08 2007 +0200 +++ b/src/tooltalk.doc Mon Aug 13 11:07:10 2007 +0200 @@ -203,7 +203,7 @@ (create-tooltalk-message) Create a new tooltalk message. The messages session attribute is -initialized to the default session. Other attributes can be intialized +initialized to the default session. Other attributes can be initialized with set-tooltalk-message-attribute. Make-tooltalk-message is the preferred to create and initialize a message. @@ -211,7 +211,7 @@ (destroy-tooltalk-message msg) Apply tt_message_destroy to the message. It's not necessary -to destroy messages after they've been proccessed by a message or +to destroy messages after they've been processed by a message or pattern callback, the Lisp/Tooltalk callback machinery does this for you. diff -r 76b7d63099ad -r 8626e4521993 src/unexcw.c --- a/src/unexcw.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/unexcw.c Mon Aug 13 11:07:10 2007 +0200 @@ -245,7 +245,7 @@ void* empty_space; extern int static_heap_dumped; SCNHDR section; - /* calculate new sizes f_ohdr.dsize is the total initalized data + /* calculate new sizes f_ohdr.dsize is the total initialized data size on disk which is f_data.s_size + f_idata.s_size. f_ohdr.data_start is the base addres of all data and so should not be changed. *.s_vaddr is the virtual address of the start diff -r 76b7d63099ad -r 8626e4521993 src/unexec.c --- a/src/unexec.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/unexec.c Mon Aug 13 11:07:10 2007 +0200 @@ -194,6 +194,7 @@ # include # include # include +# include # ifdef __lucid # include @@ -288,7 +289,7 @@ #ifdef __STDC__ #ifndef __sys_stdtypes_h -#ifndef _PTRDIFF_T +#if !defined(_PTRDIFF_T) && !defined(_BSD_PTRDIFF_T_) typedef long ptrdiff_t; #endif #endif @@ -968,7 +969,7 @@ #ifdef RISCiX - /* Acorn's RISC-iX has a wacky way of initialising the position of the heap. + /* Acorn's RISC-iX has a wacky way of initializing the position of the heap. * There is a little table in crt0.o that is filled at link time with * the min and current brk positions, among other things. When start * runs, it copies the table to where these parameters live during diff -r 76b7d63099ad -r 8626e4521993 src/widget.c --- a/src/widget.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/widget.c Mon Aug 13 11:07:10 2007 +0200 @@ -29,7 +29,6 @@ #include #include "lisp.h" #include "buffer.h" -#include "insdel.h" Lisp_Object Qwidget_type; @@ -52,7 +51,7 @@ DEFUN ("widget-put", Fwidget_put, 3, 3, 0, /* In WIDGET set PROPERTY to VALUE. -The value can later be retrived with `widget-get'. +The value can later be retrieved with `widget-get'. */ (widget, property, value)) { @@ -68,12 +67,11 @@ */ (widget, property)) { - Lisp_Object tmp, value; + Lisp_Object value = Qnil; - value = Qnil; while (1) { - tmp = Fwidget_plist_member (Fcdr (widget), property); + Lisp_Object tmp = Fwidget_plist_member (Fcdr (widget), property); if (!NILP (tmp)) { value = Fcar (Fcdr (tmp)); diff -r 76b7d63099ad -r 8626e4521993 src/window.c --- a/src/window.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/window.c Mon Aug 13 11:07:10 2007 +0200 @@ -36,7 +36,6 @@ #include "glyphs.h" #include "redisplay.h" #include "window.h" -#include "commands.h" Lisp_Object Qwindowp, Qwindow_live_p, Qwindow_configurationp; Lisp_Object Qscroll_up, Qscroll_down, Qdisplay_buffer; @@ -136,36 +135,36 @@ #define MARK_DISP_VARIABLE(field) \ - ((markobj) (window->field[CURRENT_DISP])); \ - ((markobj) (window->field[DESIRED_DISP])); \ - ((markobj) (window->field[CMOTION_DISP])); + markobj (window->field[CURRENT_DISP]); \ + markobj (window->field[DESIRED_DISP]); \ + markobj (window->field[CMOTION_DISP]); static Lisp_Object mark_window (Lisp_Object obj, void (*markobj) (Lisp_Object)) { struct window *window = XWINDOW (obj); - ((markobj) (window->frame)); - ((markobj) (window->mini_p)); - ((markobj) (window->next)); - ((markobj) (window->prev)); - ((markobj) (window->hchild)); - ((markobj) (window->vchild)); - ((markobj) (window->parent)); - ((markobj) (window->buffer)); + markobj (window->frame); + markobj (window->mini_p); + markobj (window->next); + markobj (window->prev); + markobj (window->hchild); + markobj (window->vchild); + markobj (window->parent); + markobj (window->buffer); MARK_DISP_VARIABLE (start); MARK_DISP_VARIABLE (pointm); - ((markobj) (window->sb_point)); /* #### move to scrollbar.c? */ - ((markobj) (window->use_time)); + markobj (window->sb_point); /* #### move to scrollbar.c? */ + markobj (window->use_time); MARK_DISP_VARIABLE (last_modified); MARK_DISP_VARIABLE (last_point); MARK_DISP_VARIABLE (last_start); MARK_DISP_VARIABLE (last_facechange); - ((markobj) (window->line_cache_last_updated)); - ((markobj) (window->redisplay_end_trigger)); + markobj (window->line_cache_last_updated); + markobj (window->redisplay_end_trigger); mark_face_cachels (window->face_cachels, markobj); mark_glyph_cachels (window->glyph_cachels, markobj); -#define WINDOW_SLOT(slot, compare) ((markobj) (window->slot)) +#define WINDOW_SLOT(slot, compare) ((void) (markobj (window->slot))) #include "winslots.h" return Qnil; @@ -385,23 +384,21 @@ real_window_internal (Lisp_Object win, struct window_mirror *rmir, struct window_mirror *mir) { - Lisp_Object retval; - for (; !NILP (win) && rmir ; win = XWINDOW (win)->next, rmir = rmir->next) { if (mir == rmir) return win; if (!NILP (XWINDOW (win)->vchild)) { - retval = real_window_internal (XWINDOW (win)->vchild, rmir->vchild, - mir); + Lisp_Object retval = + real_window_internal (XWINDOW (win)->vchild, rmir->vchild, mir); if (!NILP (retval)) return retval; } if (!NILP (XWINDOW (win)->hchild)) { - retval = real_window_internal (XWINDOW (win)->hchild, rmir->hchild, - mir); + Lisp_Object retval = + real_window_internal (XWINDOW (win)->hchild, rmir->hchild, mir); if (!NILP (retval)) return retval; } @@ -746,7 +743,7 @@ return 1; #ifdef HAVE_SCROLLBARS - /* Our right scrollabr is enough to separate us at the right */ + /* Our right scrollbar is enough to separate us at the right */ if (NILP (w->scrollbar_on_left_p) && !NILP (w->vertical_scrollbar_visible_p) && !ZEROP (w->scrollbar_width)) @@ -785,7 +782,7 @@ /* Calculate width of vertical divider, including its shadows and spacing. The returned value is effectively the distance between adjacent window edges. This function does not check - whether a windows needs vertival divider, so the returned + whether a window needs a vertical divider, so the returned value is a "theoretical" one */ int window_divider_width (struct window *w) @@ -794,7 +791,7 @@ will have a depressed look */ if (FRAME_WIN_P (XFRAME (WINDOW_FRAME (w)))) - return + return XINT (w->vertical_divider_line_width) + 2 * XINT (w->vertical_divider_spacing) + 2 * abs (XINT (w->vertical_divider_shadow_thickness)); @@ -893,7 +890,7 @@ /* This should be an abort except I'm not yet 100% confident that it won't ever get hit (though I haven't been able to trigger it). It is extremely - unlikely to cause any noticable problem and even if + unlikely to cause any noticeable problem and even if it does it will be a minor display glitch. */ /* #### Bullshit alert. It does get hit and it causes noticeable glitches. real_current_modeline_height @@ -1051,7 +1048,7 @@ window_left_gutter_width (struct window *w, int modeline) { int gutter = window_left_toolbar_width (w); - + if (!NILP (w->hchild) || !NILP (w->vchild)) return 0; @@ -1067,8 +1064,8 @@ int window_right_gutter_width (struct window *w, int modeline) { - int gutter = window_left_toolbar_width (w); - + int gutter = window_right_toolbar_width (w); + if (!NILP (w->hchild) || !NILP (w->vchild)) return 0; @@ -1404,7 +1401,7 @@ Fwindow_text_area_pixel_width, 0, 1, 0, /* Return the width in pixels of the text-displaying portion of WINDOW. Unlike `window-pixel-width', the space occupied by the vertical -scrollbar or divider, if any, is not counted. +scrollbar or divider, if any, is not counted. */ (window)) { @@ -3168,7 +3165,7 @@ Fset_marker (w->sb_point, w->start[CURRENT_DISP], buffer); /* set start_at_line_beg correctly. GE */ w->start_at_line_beg = beginning_of_line_p (XBUFFER (buffer), - marker_position (w->start[CURRENT_DISP])); + marker_position (w->start[CURRENT_DISP])); w->force_start = 0; /* Lucid fix */ SET_LAST_MODIFIED (w, 1); SET_LAST_FACECHANGE (w); @@ -3484,9 +3481,9 @@ DEFUN ("enlarge-window", Fenlarge_window, 1, 3, "_p", /* -Make the selected window ARG lines bigger. -From program, optional second arg non-nil means grow sideways ARG columns, -and optional third ARG specifies the window to change instead of the +Make the selected window N lines bigger. +From program, optional second arg SIDE non-nil means grow sideways N columns, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3498,9 +3495,9 @@ } DEFUN ("enlarge-window-pixels", Fenlarge_window_pixels, 1, 3, "_p", /* -Make the selected window ARG pixels bigger. -From program, optional second arg non-nil means grow sideways ARG pixels, -and optional third ARG specifies the window to change instead of the +Make the selected window N pixels bigger. +From program, optional second arg SIDE non-nil means grow sideways N pixels, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3512,9 +3509,9 @@ } DEFUN ("shrink-window", Fshrink_window, 1, 3, "_p", /* -Make the selected window ARG lines smaller. -From program, optional second arg non-nil means shrink sideways ARG columns, -and optional third ARG specifies the window to change instead of the +Make the selected window N lines smaller. +From program, optional second arg SIDE non-nil means shrink sideways N columns, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3526,9 +3523,9 @@ } DEFUN ("shrink-window-pixels", Fshrink_window_pixels, 1, 3, "_p", /* -Make the selected window ARG pixels smaller. -From program, optional second arg non-nil means shrink sideways ARG pixels, -and optional third ARG specifies the window to change instead of the +Make the selected window N pixels smaller. +From program, optional second arg SIDE non-nil means shrink sideways N pixels, +and optional third arg WINDOW specifies the window to change instead of the selected window. */ (n, side, window)) @@ -3912,7 +3909,7 @@ (*setsizefun) (window, *sizep + delta1, 0); /* Squeeze out delta1 lines or columns from our parent, - shriking this window and siblings proportionately. + shrinking this window and siblings proportionately. This brings parent back to correct size. Delta1 was calculated so this makes this window the desired size, taking it all out of the siblings. */ @@ -3957,7 +3954,7 @@ } /* Always set force_start so that redisplay_window will run - thw window-scroll-functions. */ + the window-scroll-functions. */ w->force_start = 1; /* #### When the fuck does this happen? I'm so glad that history has @@ -4130,10 +4127,10 @@ } DEFUN ("scroll-up", Fscroll_up, 0, 1, "_P", /* -Scroll text of current window upward ARG lines; or near full screen if no ARG. +Scroll text of current window upward N lines; or near full screen if no arg. A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll downward. -When calling from a program, supply a number as argument or nil. +Negative N means scroll downward. +When calling from a program, supply an integer as argument or nil. On attempt to scroll past end of buffer, `end-of-buffer' is signaled. On attempt to scroll past beginning of buffer, `beginning-of-buffer' is signaled. @@ -4145,9 +4142,9 @@ } DEFUN ("scroll-down", Fscroll_down, 0, 1, "_P", /* -Scroll text of current window downward ARG lines; or near full screen if no ARG. +Scroll text of current window downward N lines; or near full screen if no arg. A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll upward. +Negative N means scroll upward. When calling from a program, supply a number as argument or nil. On attempt to scroll past end of buffer, `end-of-buffer' is signaled. On attempt to scroll past beginning of buffer, `beginning-of-buffer' is @@ -4205,9 +4202,9 @@ } DEFUN ("scroll-other-window", Fscroll_other_window, 0, 1, "_P", /* -Scroll next window upward ARG lines; or near full frame if no ARG. +Scroll next window upward N lines; or near full frame if no arg. The next window is the one below the current one; or the one at the top -if the current one is at the bottom. Negative ARG means scroll downward. +if the current one is at the bottom. Negative N means scroll downward. When calling from a program, supply a number as argument or nil. If in the minibuffer, `minibuffer-scroll-window' if non-nil @@ -4222,37 +4219,33 @@ } 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); - - 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))); + int count = (NILP (n) ? + window_char_width (w, 0) - 2 : + XINT (Fprefix_numeric_value (n))); + + 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); - - 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))); + int count = (NILP (n) ? + window_char_width (w, 0) - 2 : + XINT (Fprefix_numeric_value (n))); + + return Fset_window_hscroll (window, make_int (w->hscroll - count)); } DEFUN ("center-to-window-line", Fcenter_to_window_line, 0, 2, "_P", /* @@ -4431,7 +4424,7 @@ non-zero, the mapping is halted. Otherwise, map_windows() maps over all windows in F. - If MAPFUN creates or deletes windows, the behaviour is undefined. */ + If MAPFUN creates or deletes windows, the behavior is undefined. */ int map_windows (struct frame *f, int (*mapfun) (struct window *w, void *closure), @@ -4447,7 +4440,7 @@ { int v = map_windows_1 (FRAME_ROOT_WINDOW (XFRAME (XCAR (frmcons))), mapfun, closure); - if (v) + if (v) return v; } } @@ -4465,8 +4458,8 @@ } static void -vertical_divider_changed_in_window (Lisp_Object specifier, - struct window *w, +vertical_divider_changed_in_window (Lisp_Object specifier, + struct window *w, Lisp_Object oldval) { MARK_WINDOWS_CHANGED (w); @@ -4650,28 +4643,28 @@ { struct window_config *config = XWINDOW_CONFIGURATION (obj); int i; - ((markobj) (config->current_window)); - ((markobj) (config->current_buffer)); - ((markobj) (config->minibuffer_scroll_window)); - ((markobj) (config->root_window)); + markobj (config->current_window); + markobj (config->current_buffer); + markobj (config->minibuffer_scroll_window); + markobj (config->root_window); for (i = 0; i < config->saved_windows_count; i++) { struct saved_window *s = SAVED_WINDOW_N (config, i); - ((markobj) (s->window)); - ((markobj) (s->buffer)); - ((markobj) (s->start)); - ((markobj) (s->pointm)); - ((markobj) (s->sb_point)); - ((markobj) (s->mark)); + markobj (s->window); + markobj (s->buffer); + markobj (s->start); + markobj (s->pointm); + markobj (s->sb_point); + markobj (s->mark); #if 0 /* #### This looked like this. I do not see why specifier cached values should not be marked, as such specifiers as toolbars might have GC-able instances. Freed configs are not marked, aren't they? -- kkm */ - ((markobj) (s->dedicated)); + markobj (s->dedicated); #else -#define WINDOW_SLOT(slot, compare) ((markobj) (s->slot)) +#define WINDOW_SLOT(slot, compare) ((void) (markobj (s->slot))) #include "winslots.h" #endif } @@ -5605,7 +5598,7 @@ modeline_shadow_thickness), modeline_shadow_thickness_changed, 0, 0); - + DEFVAR_SPECIFIER ("has-modeline-p", &Vhas_modeline_p /* *Whether the modeline should be displayed. This is a specifier; use `set-specifier' to change it. @@ -5643,7 +5636,7 @@ 0, 0); DEFVAR_SPECIFIER ("vertical-divider-shadow-thickness", &Vvertical_divider_shadow_thickness /* -*How thick to draw 3D shadows around vertical dividers. +*How thick to draw 3D shadows around vertical dividers. This is a specifier; use `set-specifier' to change it. */ ); Vvertical_divider_shadow_thickness = Fmake_specifier (Qinteger); diff -r 76b7d63099ad -r 8626e4521993 src/window.h --- a/src/window.h Mon Aug 13 11:06:08 2007 +0200 +++ b/src/window.h Mon Aug 13 11:07:10 2007 +0200 @@ -28,7 +28,9 @@ #define _XEMACS_WINDOW_H_ #include "redisplay.h" +#ifdef HAVE_SCROLLBARS #include "scrollbar.h" +#endif /* All windows in use are arranged into a tree, with pointers up and down. diff -r 76b7d63099ad -r 8626e4521993 src/xgccache.c --- a/src/xgccache.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/xgccache.c Mon Aug 13 11:07:10 2007 +0200 @@ -43,7 +43,7 @@ used ones first). So if faces get changed, their GCs will eventually be recycled. Also more sharing of GCs is possible. - This code uses hashtables. It could be that, if the cache size is small + This code uses hash tables. It could be that, if the cache size is small enough, a linear search might be faster; but I doubt it, since we need `equal' comparisons, not `eq', and I expect that the optimal cache size will be ~100. @@ -84,7 +84,7 @@ struct gc_cache_cell *head; struct gc_cache_cell *tail; #ifdef GCCACHE_HASH - c_hashtable table; + struct hash_table *table; #endif int create_count; @@ -129,7 +129,7 @@ cache->create_count = cache->delete_count = 0; #ifdef GCCACHE_HASH cache->table = - make_general_hashtable (GC_CACHE_SIZE, gc_cache_hash, gc_cache_eql); + make_general_hash_table (GC_CACHE_SIZE, gc_cache_hash, gc_cache_eql); #endif return cache; } @@ -147,7 +147,7 @@ rest = next; } #ifdef GCCACHE_HASH - free_hashtable (cache->table); + free_hash_table (cache->table); #endif xfree (cache); } @@ -268,8 +268,6 @@ #ifdef DEBUG_XEMACS -#include - void describe_gc_cache (struct gc_cache *cache); void describe_gc_cache (struct gc_cache *cache) @@ -290,32 +288,35 @@ gc_cache_hash (&cell->gcvm) == gc_cache_hash (&cell2->gcvm)) stderr_out ("\tHASH COLLISION with cell %d\n", i); stderr_out ("\tmask: %8lx\n", cell->gcvm.mask); -#define F(x) (int)cell->gcvm.gcv.x -#define G(w,x) if (F(x) != (~0)) stderr_out ("\t%-12s%8x\n", w, F(x)) - G("function:", function); - G("plane_mask:", plane_mask); - G("foreground:", foreground); - G("background:", background); - G("line_width:", line_width); - G("line_style:", line_style); - G("cap_style:", cap_style); - G("join_style:", join_style); - G("fill_style:", fill_style); - G("fill_rule:", fill_rule); - G("arc_mode:", arc_mode); - G("tile:", tile); - G("stipple:", stipple); - G("tsx_origin:", ts_x_origin); - G("tsy_origin:", ts_y_origin); - G("font:", font); - G("subwindow:", subwindow_mode); - G("gexposures:", graphics_exposures); - G("clip_x:", clip_x_origin); - G("clip_y:", clip_y_origin); - G("clip_mask:", clip_mask); - G("dash_off:", dash_offset); -#undef F -#undef G + +#define FROB(field) do { \ + if ((int)cell->gcvm.gcv.field != (~0)) \ + stderr_out ("\t%-12s%8x\n", #field ":", (int)cell->gcvm.gcv.field); \ +} while (0) + FROB (function); + FROB (plane_mask); + FROB (foreground); + FROB (background); + FROB (line_width); + FROB (line_style); + FROB (cap_style); + FROB (join_style); + FROB (fill_style); + FROB (fill_rule); + FROB (arc_mode); + FROB (tile); + FROB (stipple); + FROB (ts_x_origin); + FROB (ts_y_origin); + FROB (font); + FROB (subwindow_mode); + FROB (graphics_exposures); + FROB (clip_x_origin); + FROB (clip_y_origin); + FROB (clip_mask); + FROB (dash_offset); +#undef FROB + count++; if (cell->next && cell == cache->tail) stderr_out ("\nERROR! tail is here!\n\n"); diff -r 76b7d63099ad -r 8626e4521993 src/xmu.c --- a/src/xmu.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/xmu.c Mon Aug 13 11:07:10 2007 +0200 @@ -158,7 +158,7 @@ /* - * Based on an optimized version provided by Jim Becker, Auguest 5, 1988. + * Based on an optimized version provided by Jim Becker, August 5, 1988. */ @@ -388,7 +388,7 @@ /* * XmuPrintDefaultErrorMessage - print a nice error that looks like the usual - * message. Returns 1 if the caller should consider exitting else 0. + * message. Return 1 if the caller should consider exiting, else 0. */ int XmuPrintDefaultErrorMessage (Display *dpy, XErrorEvent *event, FILE *fp) { diff -r 76b7d63099ad -r 8626e4521993 src/xselect.c --- a/src/xselect.c Mon Aug 13 11:06:08 2007 +0200 +++ b/src/xselect.c Mon Aug 13 11:07:10 2007 +0200 @@ -688,7 +688,6 @@ { /* This function can GC */ struct gcpro gcpro1, gcpro2, gcpro3; - XSelectionEvent reply; Lisp_Object local_selection_data = Qnil; Lisp_Object selection_symbol; Lisp_Object target_symbol = Qnil; @@ -700,37 +699,24 @@ GCPRO3 (local_selection_data, converted_selection, target_symbol); - reply.type = SelectionNotify; /* Construct the reply event */ - reply.display = event->display; - reply.requestor = event->requestor; - reply.selection = event->selection; - reply.time = event->time; - reply.target = event->target; - reply.property = (event->property == None ? event->target : event->property); - selection_symbol = x_atom_to_symbol (d, event->selection); local_selection_data = assq_no_quit (selection_symbol, Vselection_alist); #if 0 -# define CDR(x) (XCDR (x)) -# define CAR(x) (XCAR (x)) /* This list isn't user-visible, so it can't "go bad." */ - if (!CONSP (local_selection_data)) abort (); - if (!CONSP (CDR (local_selection_data))) abort (); - if (!CONSP (CDR (CDR (local_selection_data)))) abort (); - if (!NILP (CDR (CDR (CDR (local_selection_data))))) abort (); - if (!CONSP (CAR (CDR (CDR (local_selection_data))))) abort (); - if (!INTP (CAR (CAR (CDR (CDR (local_selection_data)))))) abort (); - if (!INTP (CDR (CAR (CDR (CDR (local_selection_data)))))) abort (); -# undef CAR -# undef CDR + assert (CONSP (local_selection_data)); + assert (CONSP (XCDR (local_selection_data))); + assert (CONSP (XCDR (XCDR (local_selection_data)))); + assert (NILP (XCDR (XCDR (XCDR (local_selection_data))))); + assert (CONSP (XCAR (XCDR (XCDR (local_selection_data))))); + assert (INTP (XCAR (XCAR (XCDR (XCDR (local_selection_data)))))); + assert (INTP (XCDR (XCAR (XCDR (XCDR (local_selection_data)))))); #endif if (NILP (local_selection_data)) { - /* Someone asked for the selection, but we don't have it any more. - */ + /* Someone asked for the selection, but we don't have it any more. */ x_decline_selection_request (event); goto DONE_LABEL; } @@ -742,8 +728,7 @@ local_selection_time > event->time) { /* Someone asked for the selection, and we have one, but not the one - they're looking for. - */ + they're looking for. */ x_decline_selection_request (event); goto DONE_LABEL; } @@ -1152,7 +1137,7 @@ total_size = bytes_remaining + 1; *data_ret = (unsigned char *) xmalloc (total_size); - /* Now read, until weve gotten it all. */ + /* Now read, until we've gotten it all. */ while (bytes_remaining) { #if 0 @@ -1215,7 +1200,7 @@ int tmp_size_bytes; wait_for_property_change (prop_id); /* expect it again immediately, because x_get_window_property may - .. no it wont, I dont get it. + .. no it won't, I don't get it. .. Ok, I get it now, the Xt code that implements INCR is broken. */ prop_id = expect_property_change (display, window, property, diff -r 76b7d63099ad -r 8626e4521993 tests/automated/byte-compiler-tests.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/byte-compiler-tests.el Mon Aug 13 11:07:10 2007 +0200 @@ -0,0 +1,93 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test byte-compiler functionality +;;; See test-harness.el + +(condition-case err + (require 'test-harness) + (file-error + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path) + (require 'test-harness)))) + +(require 'bytecomp) + +;; test constant symbol warnings +(defmacro check-byte-compiler-message (message-regexp &rest body) + `(Check-Message ,message-regexp (byte-compile '(lambda () ,@body)))) + +(check-byte-compiler-message "Attempt to set non-symbol" (setq 1 1)) +(check-byte-compiler-message "Attempt to set constant symbol" (setq t 1)) +(check-byte-compiler-message "Attempt to set constant symbol" (setq nil 1)) +(check-byte-compiler-message "^$" (defconst :foo 1)) + +(check-byte-compiler-message "Attempt to let-bind non-symbol" (let ((1 'x)) 1)) +(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((t 'x)) (foo))) +(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((nil 'x)) (foo))) +(check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((:foo 'x)) (foo))) + + +(check-byte-compiler-message "bound but not referenced" (let ((foo 'x)) 1)) +(Assert (not (boundp 'free-variable))) +(Assert (boundp 'byte-compile-warnings)) +(check-byte-compiler-message "assignment to free variable" (setq free-variable 1)) +(check-byte-compiler-message "reference to free variable" (car free-variable)) +(check-byte-compiler-message "called with 2 args, but requires 1" (car 'x 'y)) + +(check-byte-compiler-message "^$" (setq :foo 1)) +(let ((fun '(lambda () (setq :foo 1)))) + (fset 'test-byte-compiler-fun fun)) +(Check-Error setting-constant (test-byte-compiler-fun)) +(byte-compile 'test-byte-compiler-fun) +(Check-Error setting-constant (test-byte-compiler-fun)) + +(eval-when-compile (defvar setq-test-foo nil) (defvar setq-test-bar nil)) +(progn + (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo)) + (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo 1 setq-test-bar)) + (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo)) + (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo 1 setq-test-bar)) + ) + +;;----------------------------------------------------- +;; let, let* +;;----------------------------------------------------- + +;; Test interpreted and compiled lisp separately here +(check-byte-compiler-message "malformed let binding" (let ((x 1 2)) 3)) +(check-byte-compiler-message "malformed let binding" (let* ((x 1 2)) 3)) + +(Check-Error-Message + error "`let' bindings can have only one value-form" + (eval '(let ((x 1 2)) 3))) + +(Check-Error-Message + error "`let' bindings can have only one value-form" + (eval '(let* ((x 1 2)) 3))) + diff -r 76b7d63099ad -r 8626e4521993 tests/automated/database-tests.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/database-tests.el Mon Aug 13 11:07:10 2007 +0200 @@ -0,0 +1,62 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests, database + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test database functionality +;;; See test-harness.el + +(condition-case err + (require 'test-harness) + (file-error + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path) + (require 'test-harness)))) + +(flet ((test-database + (db) + (Assert (databasep db)) + (put-database "key1" "val1" db) + (Assert (equal "val1" (get-database "key1" db))) + (remove-database "key1" db) + (Assert (equal nil (get-database "key1" db))) + (close-database db) + (Assert (not (database-live-p db))) + (Assert (databasep db)) + (let ((filename (database-file-name db))) + (dolist (fn (list filename (concat filename ".db"))) + (condition-case nil (delete-file fn) (file-error nil)))))) + + (let ((filename (expand-file-name "test-harness" (temp-directory)))) + + (dolist (fn (list filename (concat filename ".db"))) + (condition-case nil (delete-file fn) (file-error nil))) + + (dolist (db-type `(dbm berkeley-db)) + (when (featurep db-type) + (princ "\n") + (test-database (open-database filename db-type)))) + )) diff -r 76b7d63099ad -r 8626e4521993 tests/automated/hash-table-tests.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/hash-table-tests.el Mon Aug 13 11:07:10 2007 +0200 @@ -0,0 +1,269 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests, database + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test database functionality +;;; See test-harness.el + +(condition-case err + (require 'test-harness) + (file-error + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path) + (require 'test-harness)))) + +;; Test all combinations of make-hash-table keywords +(dolist (type `(non-weak weak key-weak value-weak)) + (dolist (test `(eq eql equal)) + (dolist (size `(0 1 100)) + (dolist (rehash-size `(1.1 9.9)) + (dolist (rehash-threshold `(0.2 .9)) + (dolist (data `(() (1 2) (1 2 3 4))) + (let ((ht (make-hash-table :test test + :type type + :size size + :rehash-size rehash-size + :rehash-threshold rehash-threshold))) + (Assert (equal ht (car (let ((print-readably t)) + (read-from-string (prin1-to-string ht)))))) + (Assert (eq test (hash-table-test ht))) + (Assert (eq type (hash-table-type ht))) + (Assert (<= size (hash-table-size ht))) + (Assert (eql rehash-size (hash-table-rehash-size ht))) + (Assert (eql rehash-threshold (hash-table-rehash-threshold ht)))))))))) + +(loop for (fun type) in `((make-hashtable non-weak) + (make-weak-hashtable weak) + (make-key-weak-hashtable key-weak) + (make-value-weak-hashtable value-weak)) + do (Assert (eq type (hash-table-type (funcall fun 10))))) + +(let ((ht (make-hash-table :size 20 :rehash-threshold .75 :test 'eq)) + (size 80)) + (Assert (hashtablep ht)) + (Assert (hash-table-p ht)) + (Assert (eq 'eq (hash-table-test ht))) + (Assert (eq 'non-weak (hash-table-type ht))) + (Assert (eq 'non-weak (hashtable-type ht))) + (dotimes (j size) + (puthash j (- j) ht) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j))) + (Assert (= (hashtable-fullness ht) (hash-table-count ht))) + (puthash j j ht) + (Assert (eq (gethash j ht 'foo) j)) + (Assert (= (hash-table-count ht) (1+ j))) + (setf (gethash j ht) (- j)) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) + + (clrhash ht) + (Assert (= 0 (hash-table-count ht))) + + (dotimes (j size) + (puthash j (- j) ht) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) + + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) + (print k-sum) + (print v-sum) + (Assert (= k-sum (/ (* size (- size 1)) 2))) + (Assert (= v-sum (- k-sum)))) + + (let ((count size)) + (dotimes (j size) + (remhash j ht) + (Assert (eq (gethash j ht) nil)) + (Assert (eq (gethash j ht 'foo) 'foo)) + (Assert (= (hash-table-count ht) (decf count)))))) + +(let ((ht (make-hash-table :size 30 :rehash-threshold .25 :test 'equal)) + (size 70)) + (Assert (hashtablep ht)) + (Assert (hash-table-p ht)) + (Assert (>= (hash-table-size ht) (/ 30 .25))) + (Assert (eql .25 (hash-table-rehash-threshold ht))) + (Assert (eq 'equal (hash-table-test ht))) + (Assert (eq (hash-table-test ht) (hashtable-test-function ht))) + (Assert (eq 'non-weak (hash-table-type ht))) + (dotimes (j size) + (puthash (int-to-string j) (- j) ht) + (Assert (eq (gethash (int-to-string j) ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j))) + (puthash (int-to-string j) j ht) + (Assert (eq (gethash (int-to-string j) ht 'foo) j)) + (Assert (= (hash-table-count ht) (1+ j)))) + + (clrhash ht) + (Assert (= 0 (hash-table-count ht))) + (Assert (equal ht (copy-hash-table ht))) + + (dotimes (j size) + (setf (gethash (int-to-string j) ht) (- j)) + (Assert (eq (gethash (int-to-string j) ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) + + (let ((count size)) + (dotimes (j size) + (remhash (int-to-string j) ht) + (Assert (eq (gethash (int-to-string j) ht) nil)) + (Assert (eq (gethash (int-to-string j) ht 'foo) 'foo)) + (Assert (= (hash-table-count ht) (decf count)))))) + +(let ((iterations 5) (one 1.0) (two 2.0)) + (flet ((check-copy + (ht) + (let ((copy-of-ht (copy-hash-table ht))) + (Assert (equal ht copy-of-ht)) + (Assert (not (eq ht copy-of-ht))) + (Assert (eq (hash-table-count ht) (hash-table-count copy-of-ht))) + (Assert (eq (hash-table-type ht) (hash-table-type copy-of-ht))) + (Assert (eq (hash-table-size ht) (hash-table-size copy-of-ht))) + (Assert (eql (hash-table-rehash-size ht) (hash-table-rehash-size copy-of-ht))) + (Assert (eql (hash-table-rehash-threshold ht) (hash-table-rehash-threshold copy-of-ht)))))) + + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eq))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash (+ two 0.0) t ht) + (puthash (concat "1" "2") t ht) + (puthash (concat "3" "4") t ht)) + (Assert (eq (hashtable-test-function ht) 'eq)) + (Assert (eq (hash-table-test ht) 'eq)) + (Assert (= (* iterations 4) (hash-table-count ht))) + (Assert (eq nil (gethash 1.0 ht))) + (Assert (eq nil (gethash "12" ht))) + (check-copy ht) + ) + + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eql))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash (+ two 0.0) t ht) + (puthash (concat "1" "2") t ht) + (puthash (concat "3" "4") t ht)) + (Assert (eq (hashtable-test-function ht) 'eql)) + (Assert (eq (hash-table-test ht) 'eql)) + (Assert (= (+ 2 (* 2 iterations)) (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq nil (gethash "12" ht))) + (check-copy ht) + ) + + (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'equal))) + (dotimes (j iterations) + (puthash (+ one 0.0) t ht) + (puthash (+ two 0.0) t ht) + (puthash (concat "1" "2") t ht) + (puthash (concat "3" "4") t ht)) + (Assert (eq (hashtable-test-function ht) 'equal)) + (Assert (eq (hash-table-test ht) 'equal)) + (Assert (= 4 (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq t (gethash "12" ht))) + (check-copy ht) + ) + + )) + +;; Test that weak hash-tables are properly handled +(loop for (type expected-count expected-k-sum expected-v-sum) in + `((non-weak 6 38 25) + (weak 3 6 9) + (key-weak 4 38 9) + (value-weak 4 6 25)) + do + (let* ((ht (make-hash-table :type type)) + (my-obj (cons ht ht))) + (garbage-collect) + (puthash my-obj 1 ht) + (puthash 2 my-obj ht) + (puthash 4 8 ht) + (puthash (cons ht ht) 16 ht) + (puthash 32 (cons ht ht) ht) + (puthash (cons ht ht) (cons ht ht) ht) + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) + (when (integerp k) (incf k-sum k)) + (when (integerp v) (incf v-sum v))) + ht) + (Assert (eq 38 k-sum)) + (Assert (eq 25 v-sum))) + (Assert (eq 6 (hash-table-count ht))) + (garbage-collect) + (Assert (eq expected-count (hash-table-count ht))) + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) + (when (integerp k) (incf k-sum k)) + (when (integerp v) (incf v-sum v))) + ht) + (Assert (eq expected-k-sum k-sum)) + (Assert (eq expected-v-sum v-sum))))) + +;;; Test the ability to puthash and remhash the current elt of a maphash +(let ((ht (make-hash-table :test 'eql))) + (dotimes (j 100) (setf (gethash j ht) (- j))) + (maphash #'(lambda (k v) + (if (oddp k) (remhash k ht) (puthash k (- v) ht))) + ht) + (let ((k-sum 0) (v-sum 0)) + (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) + (Assert (= (* 50 49) k-sum)) + (Assert (= v-sum k-sum)))) + +;;; Test reading and printing of hash-table objects +(let ((h1 #s(hashtable type weak rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) + (h2 #s(hash-table type weak rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) + (h3 (make-hash-table :type 'weak :rehash-size 3.0 :rehash-threshold .2 :test 'eq))) + (Assert (equal h1 h2)) + (Assert (not (equal h1 h3))) + (puthash 1 2 h3) + (puthash 3 4 h3) + (Assert (equal h1 h3))) + +;;; Testing equality of hash tables +(Assert (equal (make-hash-table :test 'eql :size 300 :rehash-threshold .9 :rehash-size 3.0) + (make-hash-table :test 'eql))) +(Assert (not (equal (make-hash-table :test 'eq) + (make-hash-table :test 'equal)))) +(let ((h1 (make-hash-table)) + (h2 (make-hash-table))) + (Assert (equal h1 h2)) + (Assert (not (eq h1 h2))) + (puthash 1 2 h1) + (Assert (not (equal h1 h2))) + (puthash 1 2 h2) + (Assert (equal h1 h2)) + (puthash 1 3 h2) + (Assert (not (equal h1 h2))) + (clrhash h1) + (Assert (not (equal h1 h2))) + (clrhash h2) + (Assert (equal h1 h2)) + ) diff -r 76b7d63099ad -r 8626e4521993 tests/automated/lisp-tests.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/lisp-tests.el Mon Aug 13 11:07:10 2007 +0200 @@ -0,0 +1,727 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Maintainer: Martin Buchholz +;; Created: 1998 +;; Keywords: tests + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: not in FSF Emacs. + +;;; Commentary: + +;;; Test basic Lisp engine functionality +;;; See test-harness.el for instructions on how to run these tests. + +(eval-when-compile + (condition-case nil + (require 'test-harness) + (file-error + (push "." load-path) + (when (and (boundp 'load-file-name) (stringp load-file-name)) + (push (file-name-directory load-file-name) load-path)) + (require 'test-harness)))) + +(Check-Error wrong-number-of-arguments (setq setq-test-foo)) +(Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) +(Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) +(Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) +(Assert (eq (setq) nil)) +(Assert (eq (setq-default) nil)) +(Assert (eq (setq setq-test-foo 42) 42)) +(Assert (eq (setq-default setq-test-foo 42) 42)) +(Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99)) +(Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)) + +(macrolet ((test-setq (expected-result &rest body) + `(progn + (defun test-setq-fun () ,@body) + (Assert (eq ,expected-result (test-setq-fun))) + (byte-compile 'test-setq-fun) + (Assert (eq ,expected-result (test-setq-fun)))))) + (test-setq nil (setq)) + (test-setq nil (setq-default)) + (test-setq 42 (setq test-setq-var 42)) + (test-setq 42 (setq-default test-setq-var 42)) + (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) + (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) + ) + +(let ((my-vector [1 2 3 4]) + (my-bit-vector (bit-vector 1 0 1 0)) + (my-string "1234") + (my-list '(1 2 3 4))) + + ;;(Assert (fooooo)) ;; Generate Other failure + ;;(Assert (eq 1 2)) ;; Generate Assertion failure + + (dolist (sequence (list my-vector my-bit-vector my-string my-list)) + (Assert (sequencep sequence)) + (Assert (eq 4 (length sequence)))) + + (dolist (array (list my-vector my-bit-vector my-string)) + (Assert (arrayp array))) + + (Assert (eq (elt my-vector 0) 1)) + (Assert (eq (elt my-bit-vector 0) 1)) + (Assert (eq (elt my-string 0) ?1)) + (Assert (eq (elt my-list 0) 1)) + + (fillarray my-vector 5) + (fillarray my-bit-vector 1) + (fillarray my-string ?5) + + (dolist (array (list my-vector my-bit-vector)) + (Assert (eq 4 (length array)))) + + (Assert (eq (elt my-vector 0) 5)) + (Assert (eq (elt my-bit-vector 0) 1)) + (Assert (eq (elt my-string 0) ?5)) + + (Assert (eq (elt my-vector 3) 5)) + (Assert (eq (elt my-bit-vector 3) 1)) + (Assert (eq (elt my-string 3) ?5)) + + (fillarray my-bit-vector 0) + (Assert (eq 4 (length my-bit-vector))) + (Assert (eq (elt my-bit-vector 2) 0)) + ) + +(defun make-circular-list (length) + "Create evil emacs-crashing circular list of length LENGTH" + (let ((circular-list + (make-list + length + 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) + (setcdr (last circular-list) circular-list) + circular-list)) + +;;----------------------------------------------------- +;; Test `nconc' +;;----------------------------------------------------- +(defun make-list-012 () (list 0 1 2)) + +(Check-Error wrong-type-argument (nconc 'foo nil)) + +(dolist (length `(1 2 3 4 1000 2000)) + (Check-Error circular-list (nconc (make-circular-list length) 'foo)) + (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) + (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) + +(Assert (eq (nconc) nil)) +(Assert (eq (nconc nil) nil)) +(Assert (eq (nconc nil nil) nil)) +(Assert (eq (nconc nil nil nil) nil)) + +(let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x nil) x))) +(let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x))) + +(Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) + +(let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) + (Assert (eq (length y) 6)) + (Assert (eq (nth 3 y) 3))) + +;;----------------------------------------------------- +;; Test `last' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (last 'foo)) +(Check-Error wrong-number-of-arguments (last)) +(Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) +(Check-Error circular-list (last (make-circular-list 1))) +(Check-Error circular-list (last (make-circular-list 2000))) +(let ((x (list 0 1 2 3))) + (Assert (eq (last nil) nil)) + (Assert (eq (last x 0) nil)) + (Assert (eq (last x ) (cdddr x))) + (Assert (eq (last x 1) (cdddr x))) + (Assert (eq (last x 2) (cddr x))) + (Assert (eq (last x 3) (cdr x))) + (Assert (eq (last x 4) x)) + (Assert (eq (last x 9) x)) + (Assert (eq (last `(1 . 2) 0) 2)) + ) + +;;----------------------------------------------------- +;; Test `butlast' and `nbutlast' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (butlast 'foo)) +(Check-Error wrong-type-argument (nbutlast 'foo)) +(Check-Error wrong-number-of-arguments (butlast)) +(Check-Error wrong-number-of-arguments (nbutlast)) +(Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) +(Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) +(Check-Error circular-list (butlast (make-circular-list 1))) +(Check-Error circular-list (nbutlast (make-circular-list 1))) +(Check-Error circular-list (butlast (make-circular-list 2000))) +(Check-Error circular-list (nbutlast (make-circular-list 2000))) + +(let* ((x (list 0 1 2 3)) + (y (butlast x)) + (z (nbutlast x))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2))) + (Assert (equal z y))) + +(let* ((x (list 0 1 2 3 4)) + (y (butlast x 2)) + (z (nbutlast x 2))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2))) + (Assert (equal z y))) + +(let* ((x (list 0 1 2 3)) + (y (butlast x 0)) + (z (nbutlast x 0))) + (Assert (eq z x)) + (Assert (not (eq y x))) + (Assert (equal y '(0 1 2 3))) + (Assert (equal z y))) + +(Assert (eq (butlast '(x)) nil)) +(Assert (eq (nbutlast '(x)) nil)) +(Assert (eq (butlast '()) nil)) +(Assert (eq (nbutlast '()) nil)) + +;;----------------------------------------------------- +;; Test `copy-list' +;;----------------------------------------------------- +(Check-Error wrong-type-argument (copy-list 'foo)) +(Check-Error wrong-number-of-arguments (copy-list)) +(Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) +(Check-Error circular-list (copy-list (make-circular-list 1))) +(Check-Error circular-list (copy-list (make-circular-list 2000))) +(Assert (eq '() (copy-list '()))) +(dolist (x `((1) (1 2) (1 2 3) (1 2 . 3))) + (let ((y (copy-list x))) + (Assert (and (equal x y) (not (eq x y)))))) + +;;----------------------------------------------------- +;; Arithmetic operations +;;----------------------------------------------------- + +;; Test `+' +(Assert (eq (+ 1 1) 2)) +(Assert (= (+ 1.0 1.0) 2.0)) +(Assert (= (+ 1.0 3.0 0.0) 4.0)) +(Assert (= (+ 1 1.0) 2.0)) +(Assert (= (+ 1.0 1) 2.0)) +(Assert (= (+ 1.0 1 1) 3.0)) +(Assert (= (+ 1 1 1.0) 3.0)) + +;; Test `-' +(Check-Error wrong-number-of-arguments (-)) +(Assert (eq (- 0) 0)) +(Assert (eq (- 1) -1)) +(dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) + (Assert (= (+ 1 one) 2)) + (Assert (= (+ one) 1)) + (Assert (= (+ one) one)) + (Assert (= (- one) -1)) + (Assert (= (- one one) 0)) + (Assert (= (- one one one) -1)) + (Assert (= (+ one 1) 2)) + (dolist (zero `(0 0.0 ?\0)) + (Assert (= (+ 1 zero) 1)) + (Assert (= (+ zero 1) 1)) + (Assert (= (- zero) zero)) + (Assert (= (- zero) 0)) + (Assert (= (- zero zero) 0)) + (Assert (= (- zero one one) -2)))) + +(Assert (= (- 1.5 1) .5)) +(Assert (= (- 1 1.5) (- .5))) + +;; Test `/' + +;; Test division by zero errors +(dolist (zero `(0 0.0 ?\0)) + (Check-Error arith-error (/ zero)) + (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) + (Check-Error arith-error (/ n1 zero)) + (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) + (Check-Error arith-error (/ n1 n2 zero))))) + +;; Other tests for `/' +(Check-Error wrong-number-of-arguments (/)) +(let (x) + (Assert (= (/ (setq x 2)) 0)) + (Assert (= (/ (setq x 2.0)) 0.5))) + +(dolist (six `(6 6.0 ?\06)) + (dolist (two `(2 2.0 ?\02)) + (dolist (three `(3 3.0 ?\03)) + (Assert (= (/ six two) three))))) + +(dolist (three `(3 3.0 ?\03)) + (Assert (= (/ three 2.0) 1.5))) +(dolist (two `(2 2.0 ?\02)) + (Assert (= (/ 3.0 two) 1.5))) + +;; Test `*' +(Assert (= 1 (*))) + +(dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) + (Assert (= 1 (* one)))) + +(dolist (two `(2 2.0 ?\02)) + (Assert (= 2 (* two)))) + +(dolist (six `(6 6.0 ?\06)) + (dolist (two `(2 2.0 ?\02)) + (dolist (three `(3 3.0 ?\03)) + (Assert (= (* three two) six))))) + +(dolist (three `(3 3.0 ?\03)) + (dolist (two `(2 2.0 ?\02)) + (Assert (= (* 1.5 two) three)) + (dolist (five `(5 5.0 ?\05)) + (Assert (= 30 (* five two three)))))) + +;; Test `+' +(Assert (= 0 (+))) + +(dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) + (Assert (= 1 (+ one)))) + +(dolist (two `(2 2.0 ?\02)) + (Assert (= 2 (+ two)))) + +(dolist (five `(5 5.0 ?\05)) + (dolist (two `(2 2.0 ?\02)) + (dolist (three `(3 3.0 ?\03)) + (Assert (= (+ three two) five)) + (Assert (= 10 (+ five two three)))))) + +;; Test `max', `min' +(dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) + (Assert (= one (max one))) + (Assert (= one (max one one))) + (Assert (= one (max one one one))) + (Assert (= one (min one))) + (Assert (= one (min one one))) + (Assert (= one (min one one one))) + (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) + (Assert (= one (min one two))) + (Assert (= one (min one two two))) + (Assert (= one (min two two one))) + (Assert (= two (max one two))) + (Assert (= two (max one two two))) + (Assert (= two (max two two one))))) + +;;----------------------------------------------------- +;; Logical bit-twiddling operations +;;----------------------------------------------------- +(Assert (= (logxor) 0)) +(Assert (= (logior) 0)) +(Assert (= (logand) -1)) + +(Check-Error wrong-type-argument (logxor 3.0)) +(Check-Error wrong-type-argument (logior 3.0)) +(Check-Error wrong-type-argument (logand 3.0)) + +(dolist (three `(3 ?\03)) + (Assert (eq 3 (logand three))) + (Assert (eq 3 (logxor three))) + (Assert (eq 3 (logior three))) + (Assert (eq 3 (logand three three))) + (Assert (eq 0 (logxor three three))) + (Assert (eq 3 (logior three three)))) + +(dolist (one `(1 ?\01 ,(Int-to-Marker 1))) + (dolist (two `(2 ?\02)) + (Assert (eq 0 (logand one two))) + (Assert (eq 3 (logior one two))) + (Assert (eq 3 (logxor one two)))) + (dolist (three `(3 ?\03)) + (Assert (eq 1 (logand one three))) + (Assert (eq 3 (logior one three))) + (Assert (eq 2 (logxor one three))))) + +;;----------------------------------------------------- +;; Test `%', mod +;;----------------------------------------------------- +(Check-Error wrong-number-of-arguments (%)) +(Check-Error wrong-number-of-arguments (% 1)) +(Check-Error wrong-number-of-arguments (% 1 2 3)) + +(Check-Error wrong-number-of-arguments (mod)) +(Check-Error wrong-number-of-arguments (mod 1)) +(Check-Error wrong-number-of-arguments (mod 1 2 3)) + +(Check-Error wrong-type-argument (% 10.0 2)) +(Check-Error wrong-type-argument (% 10 2.0)) + +(dotimes (j 30) + (let ((x (- (random) (random)))) + (Assert (eq x (+ (% x 17) (* (/ x 17) 17)))) + (Assert (eq (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)))) + (Assert (eq (% x -17) (- (% (- x) 17)))) + )) + +(macrolet + ((division-test (seven) + `(progn + (Assert (eq (% ,seven 2) 1)) + (Assert (eq (% ,seven -2) 1)) + (Assert (eq (% (- ,seven) 2) -1)) + (Assert (eq (% (- ,seven) -2) -1)) + + (Assert (eq (% ,seven 4) 3)) + (Assert (eq (% ,seven -4) 3)) + (Assert (eq (% (- ,seven) 4) -3)) + (Assert (eq (% (- ,seven) -4) -3)) + + (Assert (eq (% 35 ,seven) 0)) + (Assert (eq (% -35 ,seven) 0)) + (Assert (eq (% 35 (- ,seven)) 0)) + (Assert (eq (% -35 (- ,seven)) 0)) + + (Assert (eq (mod ,seven 2) 1)) + (Assert (eq (mod ,seven -2) -1)) + (Assert (eq (mod (- ,seven) 2) 1)) + (Assert (eq (mod (- ,seven) -2) -1)) + + (Assert (eq (mod ,seven 4) 3)) + (Assert (eq (mod ,seven -4) -1)) + (Assert (eq (mod (- ,seven) 4) 1)) + (Assert (eq (mod (- ,seven) -4) -3)) + + (Assert (eq (mod 35 ,seven) 0)) + (Assert (eq (mod -35 ,seven) 0)) + (Assert (eq (mod 35 (- ,seven)) 0)) + (Assert (eq (mod -35 (- ,seven)) 0)) + + (Assert (= (mod ,seven 2.0) 1.0)) + (Assert (= (mod ,seven -2.0) -1.0)) + (Assert (= (mod (- ,seven) 2.0) 1.0)) + (Assert (= (mod (- ,seven) -2.0) -1.0)) + + (Assert (= (mod ,seven 4.0) 3.0)) + (Assert (= (mod ,seven -4.0) -1.0)) + (Assert (= (mod (- ,seven) 4.0) 1.0)) + (Assert (= (mod (- ,seven) -4.0) -3.0)) + + (Assert (eq (% 0 ,seven) 0)) + (Assert (eq (% 0 (- ,seven)) 0)) + + (Assert (eq (mod 0 ,seven) 0)) + (Assert (eq (mod 0 (- ,seven)) 0)) + + (Assert (= (mod 0.0 ,seven) 0.0)) + (Assert (= (mod 0.0 (- ,seven)) 0.0))))) + + (division-test 7) + (division-test ?\07) + (division-test (Int-to-Marker 7))) + + + +;;----------------------------------------------------- +;; Arithmetic comparison operations +;;----------------------------------------------------- +(Check-Error wrong-number-of-arguments (=)) +(Check-Error wrong-number-of-arguments (<)) +(Check-Error wrong-number-of-arguments (>)) +(Check-Error wrong-number-of-arguments (<=)) +(Check-Error wrong-number-of-arguments (>=)) +(Check-Error wrong-number-of-arguments (/=)) + +;; One argument always yields t +(loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do + (Assert (eq t (= x))) + (Assert (eq t (< x))) + (Assert (eq t (> x))) + (Assert (eq t (>= x))) + (Assert (eq t (<= x))) + (Assert (eq t (/= x))) + ) + +;; Type checking +(Check-Error wrong-type-argument (= 'foo 1)) +(Check-Error wrong-type-argument (<= 'foo 1)) +(Check-Error wrong-type-argument (>= 'foo 1)) +(Check-Error wrong-type-argument (< 'foo 1)) +(Check-Error wrong-type-argument (> 'foo 1)) +(Check-Error wrong-type-argument (/= 'foo 1)) + +;; Meat +(dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) + (dolist (two `(2 2.0 ?\02)) + (Assert (< one two)) + (Assert (<= one two)) + (Assert (<= two two)) + (Assert (> two one)) + (Assert (>= two one)) + (Assert (>= two two)) + (Assert (/= one two)) + (Assert (not (/= two two))) + (Assert (not (< one one))) + (Assert (not (> one one))) + (Assert (<= one one two two)) + (Assert (not (< one one two two))) + (Assert (>= two two one one)) + (Assert (not (> two two one one))) + (Assert (= one one one)) + (Assert (not (= one one one two))) + (Assert (not (/= one two one))) + )) + +(dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) + (dolist (two `(2 2.0 ?\02)) + (Assert (< one two)) + (Assert (<= one two)) + (Assert (<= two two)) + (Assert (> two one)) + (Assert (>= two one)) + (Assert (>= two two)) + (Assert (/= one two)) + (Assert (not (/= two two))) + (Assert (not (< one one))) + (Assert (not (> one one))) + (Assert (<= one one two two)) + (Assert (not (< one one two two))) + (Assert (>= two two one one)) + (Assert (not (> two two one one))) + (Assert (= one one one)) + (Assert (not (= one one one two))) + (Assert (not (/= one two one))) + )) + +;; ad-hoc +(Assert (< 1 2)) +(Assert (< 1 2 3 4 5 6)) +(Assert (not (< 1 1))) +(Assert (not (< 2 1))) + + +(Assert (not (< 1 1))) +(Assert (< 1 2 3 4 5 6)) +(Assert (<= 1 2 3 4 5 6)) +(Assert (<= 1 2 3 4 5 6 6)) +(Assert (not (< 1 2 3 4 5 6 6))) +(Assert (<= 1 1)) + +(Assert (not (eq (point) (point-marker)))) +(Assert (= 1 (Int-to-Marker 1))) +(Assert (= (point) (point-marker))) + +;;----------------------------------------------------- +;; testing list-walker functions +;;----------------------------------------------------- +(macrolet + ((test-fun + (fun) + `(progn + (Check-Error wrong-number-of-arguments (,fun)) + (Check-Error wrong-number-of-arguments (,fun nil)) + (Check-Error malformed-list (,fun nil 1)) + ,@(loop for n in `(1 2 2000) + collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) + (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) + + (test-funs member old-member + memq old-memq + assoc old-assoc + rassoc old-rassoc + rassq old-rassq + delete old-delete + delq old-delq + remassoc remassq remrassoc remrassq)) + +(let ((x '((1 . 2) 3 (4 . 5)))) + (Assert (eq (assoc 1 x) (car x))) + (Assert (eq (assq 1 x) (car x))) + (Assert (eq (rassoc 1 x) nil)) + (Assert (eq (rassq 1 x) nil)) + (Assert (eq (assoc 2 x) nil)) + (Assert (eq (assq 2 x) nil)) + (Assert (eq (rassoc 2 x) (car x))) + (Assert (eq (rassq 2 x) (car x))) + (Assert (eq (assoc 3 x) nil)) + (Assert (eq (assq 3 x) nil)) + (Assert (eq (rassoc 3 x) nil)) + (Assert (eq (rassq 3 x) nil)) + (Assert (eq (assoc 4 x) (caddr x))) + (Assert (eq (assq 4 x) (caddr x))) + (Assert (eq (rassoc 4 x) nil)) + (Assert (eq (rassq 4 x) nil)) + (Assert (eq (assoc 5 x) nil)) + (Assert (eq (assq 5 x) nil)) + (Assert (eq (rassoc 5 x) (caddr x))) + (Assert (eq (rassq 5 x) (caddr x))) + (Assert (eq (assoc 6 x) nil)) + (Assert (eq (assq 6 x) nil)) + (Assert (eq (rassoc 6 x) nil)) + (Assert (eq (rassq 6 x) nil))) + +(let ((x '(("1" . "2") "3" ("4" . "5")))) + (Assert (eq (assoc "1" x) (car x))) + (Assert (eq (assq "1" x) nil)) + (Assert (eq (rassoc "1" x) nil)) + (Assert (eq (rassq "1" x) nil)) + (Assert (eq (assoc "2" x) nil)) + (Assert (eq (assq "2" x) nil)) + (Assert (eq (rassoc "2" x) (car x))) + (Assert (eq (rassq "2" x) nil)) + (Assert (eq (assoc "3" x) nil)) + (Assert (eq (assq "3" x) nil)) + (Assert (eq (rassoc "3" x) nil)) + (Assert (eq (rassq "3" x) nil)) + (Assert (eq (assoc "4" x) (caddr x))) + (Assert (eq (assq "4" x) nil)) + (Assert (eq (rassoc "4" x) nil)) + (Assert (eq (rassq "4" x) nil)) + (Assert (eq (assoc "5" x) nil)) + (Assert (eq (assq "5" x) nil)) + (Assert (eq (rassoc "5" x) (caddr x))) + (Assert (eq (rassq "5" x) nil)) + (Assert (eq (assoc "6" x) nil)) + (Assert (eq (assq "6" x) nil)) + (Assert (eq (rassoc "6" x) nil)) + (Assert (eq (rassq "6" x) nil))) + +(flet ((a () (list '(1 . 2) 3 '(4 . 5)))) + (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + + (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) + + (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) + + (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) + (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) + ) + + + +(flet ((a () (list '("1" . "2") "3" '("4" . "5")))) + (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) + (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) + (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) + (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) + (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) + + (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) + (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) + +;;----------------------------------------------------- +;; function-max-args, function-min-args +;;----------------------------------------------------- +(defmacro check-function-argcounts (fun min max) + `(progn + (Assert (eq (function-min-args ,fun) ,min)) + (Assert (eq (function-max-args ,fun) ,max)))) + +(check-function-argcounts 'prog1 1 nil) ; special form +(check-function-argcounts 'command-execute 1 3) ; normal subr +(check-function-argcounts 'funcall 1 nil) ; `MANY' subr +(check-function-argcounts 'garbage-collect 0 0) ; no args subr + +;; Test interpreted and compiled functions +(loop for (arglist min max) in + '(((arg1 arg2 &rest args) 2 nil) + ((arg1 arg2 &optional arg3 arg4) 2 4) + ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) + (() 0 0)) + do + (eval + `(progn + (defun test-fun ,arglist nil) + (check-function-argcounts '(lambda ,arglist nil) ,min ,max) + (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) + +;;----------------------------------------------------- +;; Detection of cyclic variable indirection loops +;;----------------------------------------------------- +(fset 'test-sym1 'test-sym1) +(Check-Error cyclic-function-indirection (test-sym1)) + +(fset 'test-sym1 'test-sym2) +(fset 'test-sym2 'test-sym1) +(Check-Error cyclic-function-indirection (test-sym1)) +(fmakunbound 'test-sym1) ; else macroexpand-internal infloops! +(fmakunbound 'test-sym2) + +;;----------------------------------------------------- +;; Test `type-of' +;;----------------------------------------------------- +(Assert (eq (type-of load-path) 'cons)) +(Assert (eq (type-of obarray) 'vector)) +(Assert (eq (type-of 42) 'integer)) +(Assert (eq (type-of ?z) 'character)) +(Assert (eq (type-of "42") 'string)) +(Assert (eq (type-of 'foo) 'symbol)) +(Assert (eq (type-of (selected-device)) 'device)) diff -r 76b7d63099ad -r 8626e4521993 tests/automated/test-harness.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/automated/test-harness.el Mon Aug 13 11:07:10 2007 +0200 @@ -0,0 +1,367 @@ +;; test-harness.el --- Run Emacs Lisp test suites. + +;;; Copyright (C) 1998 Free Software Foundation, Inc. + +;; Author: Martin Buchholz +;; Keywords: testing + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;;; A test suite harness for testing XEmacs. +;;; The actual tests are in other files in this directory. +;;; Basically you just create files of emacs-lisp, and use the +;;; Assert, Check-Error, and Check-Message functions to create tests. +;;; You run the tests using M-x test-emacs-test-file, +;;; or $(EMACS) -l .../test-harness.el -f batch-test-emacs file ... +;;; which is run for you by the `make check' target in the top-level Makefile. + +(require 'bytecomp) + +(defvar test-harness-verbose + (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) + "*Non-nil means print messages describing progress of emacs-tester.") + +(defvar test-harness-current-file nil) + +(defvar emacs-lisp-file-regexp (purecopy "\\.el$") + "*Regexp which matches Emacs Lisp source files.") + +;;;###autoload +(defun test-emacs-test-file (filename) + "Test a file of Lisp code named FILENAME. +The output file's name is made by appending `c' to the end of FILENAME." + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (eq (cdr (assq 'major-mode (buffer-local-variables))) + 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name "Test file: " file-dir nil nil file-name)))) + ;; Expand now so we get the current buffer's defaults + (setq filename (expand-file-name filename)) + + ;; If we're testing a file that's in a buffer and is modified, offer + ;; to save it first. + (or noninteractive + (let ((b (get-file-buffer (expand-file-name filename)))) + (if (and b (buffer-modified-p b) + (y-or-n-p (format "save buffer %s first? " (buffer-name b)))) + (save-excursion (set-buffer b) (save-buffer))))) + + (if (or noninteractive test-harness-verbose) + (message "Testing %s..." filename)) + (let ((test-harness-current-file filename) + input-buffer) + (save-excursion + (setq input-buffer (get-buffer-create " *Test Input*")) + (set-buffer input-buffer) + (erase-buffer) + (insert-file-contents filename) + ;; Run hooks including the uncompression hook. + ;; If they change the file name, then change it for the output also. + (let ((buffer-file-name filename) + (default-major-mode 'emacs-lisp-mode) + (enable-local-eval nil)) + (normal-mode) + (setq filename buffer-file-name))) + (test-harness-from-buffer input-buffer filename) + (kill-buffer input-buffer) + )) + +(defun test-harness-read-from-buffer (buffer) + "Read forms from BUFFER, and turn it into a lambda test form." + (let ((body nil)) + (goto-char (point-min) buffer) + (condition-case error-info + (while t + (setq body (cons (read buffer) body))) + (end-of-file nil) + (error + (princ "Unexpected error %S reading forms from buffer\n" error-info))) + `(lambda () + (defvar passes) + (defvar assertion-failures) + (defvar no-error-failures) + (defvar wrong-error-failures) + (defvar missing-message-failures) + (defvar other-failures) + + (defvar unexpected-test-suite-failure) + (defvar trick-optimizer) + + ,@(nreverse body)))) + +(defun test-harness-from-buffer (inbuffer filename) + "Run tests in buffer INBUFFER, visiting FILENAME." + (defvar trick-optimizer) + (let ((passes 0) + (assertion-failures 0) + (no-error-failures 0) + (wrong-error-failures 0) + (missing-message-failures 0) + (other-failures 0) + + (trick-optimizer nil) + (unexpected-test-suite-failure nil) + (debug-on-error t)) + (with-output-to-temp-buffer "*Test-Log*" + + (defmacro Assert (assertion) + `(condition-case error-info + (progn + (assert ,assertion) + (princ (format "PASS: %S" (quote ,assertion))) + (terpri) + (incf passes)) + (cl-assertion-failed + (princ (format "FAIL: Assertion failed: %S\n" (quote ,assertion))) + (incf assertion-failures)) + (t (princ (format "FAIL: %S ==> error: %S\n" (quote ,assertion) error-info)) + (incf other-failures) + ))) + + (defmacro Check-Error (expected-error &rest body) + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) `(quote (progn ,@body))))) + `(condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (princ (format "FAIL: %S executed successfully, but expected error %S\n" + ,quoted-body + ',expected-error)) + (incf no-error-failures)) + (,expected-error + (princ (format "PASS: %S ==> error %S, as expected\n" + ,quoted-body ',expected-error)) + (incf passes)) + (error + (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n" + ,quoted-body ',expected-error error-info)) + (incf wrong-error-failures))))) + + (defmacro Check-Error-Message (expected-error expected-error-regexp &rest body) + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) `(quote (progn ,@body))))) + `(condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (princ (format "FAIL: %S executed successfully, but expected error %S\n" + ,quoted-body + ',expected-error)) + (incf no-error-failures)) + (,expected-error + (let ((error-message (second error-info))) + (if (string-match ,expected-error-regexp error-message) + (progn + (princ (format "PASS: %S ==> error %S %S, as expected\n" + ,quoted-body error-message ',expected-error)) + (incf passes)) + (princ (format "FAIL: %S ==> got error %S as expected, but error message %S did not match regexp %S\n" + ,quoted-body ',expected-error error-message ,expected-error-regexp)) + (incf wrong-error-failures)))) + (error + (princ (format "FAIL: %S ==> expected error %S, got error %S instead\n" + ,quoted-body ',expected-error error-info)) + (incf wrong-error-failures))))) + + + (defmacro Check-Message (expected-message-regexp &rest body) + (let ((quoted-body (if (= 1 (length body)) + `(quote ,(car body)) `(quote (progn ,@body))))) + `(let ((messages "")) + (defadvice message (around collect activate) + (defvar messages) + (let ((msg-string (apply 'format (ad-get-args 0)))) + (setq messages (concat messages msg-string)) + msg-string)) + (condition-case error-info + (progn + (setq trick-optimizer (progn ,@body)) + (if (string-match ,expected-message-regexp messages) + (progn + (princ (format "PASS: %S ==> value %S, message %S, matching %S, as expected\n" + ,quoted-body trick-optimizer messages ',expected-message-regexp)) + (incf passes)) + (princ (format "FAIL: %S ==> value %S, message %S, NOT matching expected %S\n" + ,quoted-body trick-optimizer messages ',expected-message-regexp)) + (incf missing-message-failures))) + (error + (princ (format "FAIL: %S ==> unexpected error %S\n" + ,quoted-body error-info)) + (incf other-failures))) + (ad-unadvise 'message)))) + + (defmacro Ignore-Ebola (&rest body) + `(let ((debug-issue-ebola-notices -42)) ,@body)) + + (defun Int-to-Marker (pos) + (save-excursion + (set-buffer standard-output) + (save-excursion + (goto-char pos) + (point-marker)))) + + (princ "Testing Interpreted Lisp\n\n") + (condition-case error-info + (funcall (test-harness-read-from-buffer inbuffer)) + (error + (setq unexpected-test-suite-failure t) + (princ (format "Unexpected error %S while executing interpreted code\n" + error-info)) + (message "Unexpected error %S while executing interpreted code." error-info) + (message "Test suite execution aborted." error-info) + )) + (princ "\nTesting Compiled Lisp\n\n") + (let (code) + (condition-case error-info + (setq code (let ((byte-compile-warnings nil)) + (byte-compile (test-harness-read-from-buffer inbuffer)))) + (error + (princ (format "Unexpected error %S while byte-compiling code\n" + error-info)))) + (condition-case error-info + (if code (funcall code)) + (error + (princ (format "Unexpected error %S while executing byte-compiled code\n" + error-info)) + (message "Unexpected error %S while executing byte-compiled code." error-info) + (message "Test suite execution aborted." error-info) + ))) + (princ "\nSUMMARY:\n") + (princ (format "\t%5d passes\n" passes)) + (princ (format "\t%5d assertion failures\n" assertion-failures)) + (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures)) + (princ (format "\t%5d wrong-error failures\n" wrong-error-failures)) + (princ (format "\t%5d missing-message failures\n" missing-message-failures)) + (princ (format "\t%5d other failures\n" other-failures)) + (let* ((total (+ passes + assertion-failures + no-error-failures + wrong-error-failures + missing-message-failures + other-failures)) + (basename (file-name-nondirectory filename)) + (summary-msg + (if (> total 0) + (format "%s: %d of %d (%d%%) tests successful." + basename passes total (/ (* 100 passes) total)) + (format "%s: No tests run" basename)))) + (message "%s" summary-msg)) + (when unexpected-test-suite-failure + (message "Test suite execution failed unexpectedly.")) + (fmakunbound 'Assert) + (fmakunbound 'Check-Error) + (fmakunbound 'Ignore-Ebola) + (fmakunbound 'Int-to-Marker) + ))) + +(defvar test-harness-results-point-max nil) +(defmacro displaying-emacs-test-results (&rest body) + `(let ((test-harness-results-point-max test-harness-results-point-max)) + ;; Log the file name. + (test-harness-log-file) + ;; Record how much is logged now. + ;; We will display the log buffer if anything more is logged + ;; before the end of BODY. + (or test-harness-results-point-max + (save-excursion + (set-buffer (get-buffer-create "*Test-Log*")) + (setq test-harness-results-point-max (point-max)))) + (unwind-protect + (condition-case error-info + (progn ,@body) + (error + (test-harness-report-error error-info))) + (save-excursion + ;; If there were compilation warnings, display them. + (set-buffer "*Test-Log*") + (if (= test-harness-results-point-max (point-max)) + nil + (if temp-buffer-show-function + (let ((show-buffer (get-buffer-create "*Test-Log-Show*"))) + (save-excursion + (set-buffer show-buffer) + (setq buffer-read-only nil) + (erase-buffer)) + (copy-to-buffer show-buffer + (save-excursion + (goto-char test-harness-results-point-max) + (forward-line -1) + (point)) + (point-max)) + (funcall temp-buffer-show-function show-buffer)) + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char test-harness-results-point-max) + (recenter 1))))))))) + +(defun batch-test-emacs-1 (file) + (condition-case error-info + (progn (test-emacs-test-file file) t) + (error + (princ ">>Error occurred processing ") + (princ file) + (princ ": ") + (display-error error-info nil) + (terpri) + nil))) + +(defun batch-test-emacs () + "Run `test-harness' on the files remaining on the command line. +Use this from the command line, with `-batch'; +it won't work in an interactive Emacs. +Each file is processed even if an error occurred previously. +For example, invoke \"xemacs -batch -f batch-test-emacs tests/*.el\"" + ;; command-line-args-left is what is left of the command line (from + ;; startup.el) + (defvar command-line-args-left) ;Avoid 'free variable' warning + (defvar debug-issue-ebola-notices) + (if (not noninteractive) + (error "`batch-test-emacs' is to be used only with -batch")) + (let ((error nil)) + (loop for file in command-line-args-left + do + (if (file-directory-p (expand-file-name file)) + (let ((files (directory-files file)) + source) + (while files + (if (and (string-match emacs-lisp-file-regexp (car files)) + (not (auto-save-file-name-p (car files))) + (setq source (expand-file-name + (car files) + file)) + (if (null (batch-test-emacs-1 source)) + (setq error t))) + (setq files (cdr files))))) + (if (null (batch-test-emacs-1 file)) + (setq error t)))) + ;;(message "%s" (buffer-string nil nil "*Test-Log*")) + (message "Done") + (kill-emacs (if error 1 0)))) + +(provide 'test-harness) + +;;; test-harness.el ends here diff -r 76b7d63099ad -r 8626e4521993 tests/basic-lisp.el --- a/tests/basic-lisp.el Mon Aug 13 11:06:08 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ -;;; Test basic Lisp functionality - -;;(when (not (boundp 'foo)) (setq foo 1)) -;;(incf foo) -;;(print foo) - -(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 - - (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)) - - (Assert (eq 4 (length my-vector))) - (Assert (eq 4 (length my-bit-vector))) - (Assert (eq 4 (length my-string))) - - (fillarray my-vector 5) - (fillarray my-bit-vector 1) - (fillarray my-string ?5) - - (Assert (eq 4 (length my-vector))) - (Assert (eq 4 (length my-bit-vector))) - (Assert (eq 4 (length my-string))) - - (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)) - - ;; Test nconc - (let ((x (list 0 1 2))) - (Assert (eq (nconc) nil)) - (Assert (eq (nconc nil) nil)) - (Assert (eq (nconc nil x) x)) - (Assert (eq (nconc x nil) x)) - (let ((y (nconc x nil (list 3 4 5) nil))) - (Assert (eq (length y) 6)) - (Assert (eq (nth 3 y) 3)) - )) - ) - -;;; Old cruft -;;;(run-tests) - -;(defmacro Assert (assertion) -; `(condition-case error -; (progn -; (assert ,assertion) -; (princ (format "Assertion passed: %S" (quote ,assertion))) -; (terpri) -; (incf Assert-successes)) -; (cl-assertion-failed -; (princ (format "Assertion failed: %S" (quote ,assertion))) -; (terpri) -; (incf Assert-failures)) -; (t (princ (format "Test harness error: %S" error)) -; (terpri) -; (incf Harness-failures) -; ))) - - -;(defun run-tests () -; (with-output-to-temp-buffer "*Test-Log*" -; (let ((Assert-successes 0) -; (Assert-failures 0) -; (Harness-failures 0)) -; (basic-lisp-test) -; (byte-compile 'basic-lisp-test) -; (basic-lisp-test) -; (print (format "%d successes, %d assertion failures, %d harness failures" -; Assert-successes -; Assert-failures -; Harness-failures))))) - -;(defun the-test () diff -r 76b7d63099ad -r 8626e4521993 tests/database.el --- a/tests/database.el Mon Aug 13 11:06:08 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,29 +0,0 @@ -;;; Test database functionality - -(defun 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))) - (loop for fn in (list filename (concat filename ".db")) do - (when (file-exists-p fn) - (delete-file fn)))) - ) - -(let ((filename (expand-file-name "test-emacs" (temp-directory)))) - - (when (featurep 'dbm) - (let ((db (open-database filename 'dbm))) - (test-database db))) - - (princ "\n") - - (when (featurep 'berkeley-db) - (let ((db (open-database filename 'berkeley-db))) - (test-database db))) - ) diff -r 76b7d63099ad -r 8626e4521993 tests/test-emacs.el --- a/tests/test-emacs.el Mon Aug 13 11:06:08 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -;; test-emacs.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 - -(defvar test-emacs-verbose - (and (not noninteractive) (> (device-baud-rate) search-slow-speed)) - "*Non-nil means print messages describing progress of emacs-tester.") - -(defvar test-emacs-current-file nil) - -(defvar emacs-lisp-file-regexp (purecopy "\\.el$") - "*Regexp which matches Emacs Lisp source files.") - -(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 "fTest file: ") - (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-emacs-verbose) - (message "Testing %s..." filename)) - (let ((test-emacs-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-emacs-from-buffer input-buffer filename) - (kill-buffer input-buffer) - )) - -(defun test-emacs-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 nil - (while t - (setq body (cons (read inbuffer) body))) - (error nil)) - `(lambda () - (defvar passes) - (defvar assertion-failures) - (defvar other-failures) - ,@(nreverse body)))) - -(defun test-emacs-from-buffer (inbuffer filename) - "Run tests in buffer INBUFFER, visiting FILENAME." - (let ((passes 0) - (assertion-failures 0) - (other-failures 0)) - (with-output-to-temp-buffer "*Test-Log*" - (defmacro Assert (assertion) - `(condition-case error - (progn - (assert ,assertion) - (princ (format "PASS: %S" (quote ,assertion))) - (terpri) - (incf passes)) - (cl-assertion-failed - (princ (format "Assertion failed: %S" (quote ,assertion))) - (terpri) - (incf assertion-failures)) - (t (princ "Error during test execution:\n\t") - (display-error error nil) - (terpri) - (incf other-failures) - ))) - - (princ "Testing Interpreted Lisp\n\n") - (funcall (test-emacs-read-from-buffer inbuffer)) - (princ "\nTesting Compiled Lisp\n\n") - (funcall (byte-compile (test-emacs-read-from-buffer inbuffer))) - (princ (format - "\nSUMMARY: %d passes, %d assertion failures, %d other failures\n" - passes - assertion-failures - other-failures)) - (let* ((total (+ passes assertion-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)) - (fmakunbound 'Assert)))) - -(defvar test-emacs-results-point-max nil) -(defmacro displaying-emacs-test-results (&rest body) - `(let ((test-emacs-results-point-max test-emacs-results-point-max)) - ;; Log the file name. - (test-emacs-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-emacs-results-point-max - (save-excursion - (set-buffer (get-buffer-create "*Test-Log*")) - (setq test-emacs-results-point-max (point-max)))) - (unwind-protect - (condition-case error-info - (progn ,@body) - (error - (test-emacs-report-error error-info))) - (save-excursion - ;; If there were compilation warnings, display them. - (set-buffer "*Test-Log*") - (if (= test-emacs-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-emacs-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-emacs-results-point-max) - (recenter 1))))))))) - -(defun batch-test-emacs-1 (file) - (condition-case err - (progn (test-emacs-test-file file) t) - (error - (princ ">>Error occurred processing ") - (princ file) - (princ ": ") - (display-error err nil) - (terpri) - nil))) - -(defun batch-test-emacs () - "Run `test-emacs' 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 - (if (not noninteractive) - (error "`batch-test-emacs' is to be used only with -batch")) - (let ((error nil) - (debug-issue-ebola-notices 0)) - (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 "Done") - (kill-emacs (if error 1 0)))) diff -r 76b7d63099ad -r 8626e4521993 version.sh --- a/version.sh Mon Aug 13 11:06:08 2007 +0200 +++ b/version.sh Mon Aug 13 11:07:10 2007 +0200 @@ -1,8 +1,8 @@ #!/bin/sh emacs_major_version=21 emacs_minor_version=2 -emacs_beta_version=4 -xemacs_codename="Aglaophonos" +emacs_beta_version=5 +xemacs_codename="Aphrodite" infodock_major_version=4 infodock_minor_version=0 infodock_build_version=1